daniel/emacs
1
2
Fork 0
Code Issues 7 Pull Requests Projects Releases Wiki Activity

pkg update and first config fix

Browse Source 
org-brain not working, add org-roam
This commit is contained in:
Daniel Weschke
2022-12-19 23:02:34 +01:00
parent 02b3e07185
commit 82f05baffe
885 changed files with 356098 additions and 36993 deletions
Download Patch File Download Diff File Expand all files Collapse all files

145
README.md
View File

@@ -83,7 +83,7 @@ General key bindings and functions
<tr>
<td class="org-left">ace-window</td>
<td class="org-right">20200606.1259</td>
<td class="org-right">20220911.358</td>
<td class="org-left">melpa</td>
</tr>
@@ -97,7 +97,7 @@ General key bindings and functions
<tr>
<td class="org-left">all-the-icons</td>
<td class="org-right">20211225.506</td>
<td class="org-right">20220929.2303</td>
<td class="org-left">melpa</td>
</tr>
@@ -111,21 +111,21 @@ General key bindings and functions
<tr>
<td class="org-left">anaconda-mode</td>
<td class="org-right">20211122.817</td>
<td class="org-right">20220922.741</td>
<td class="org-left">melpa</td>
</tr>
<tr>
<td class="org-left">async</td>
<td class="org-right">20210823.528</td>
<td class="org-right">20221217.649</td>
<td class="org-left">melpa</td>
</tr>
<tr>
<td class="org-left">avy</td>
<td class="org-right">20220102.805</td>
<td class="org-right">20220910.1936</td>
<td class="org-left">melpa</td>
</tr>
@@ -153,21 +153,21 @@ General key bindings and functions
<tr>
<td class="org-left">bibtex-completion</td>
<td class="org-right">20211019.1306</td>
<td class="org-right">20221024.857</td>
<td class="org-left">melpa</td>
</tr>
<tr>
<td class="org-left">bind-key</td>
<td class="org-right">20210210.1609</td>
<td class="org-right">20221209.2013</td>
<td class="org-left">melpa</td>
</tr>
<tr>
<td class="org-left">citeproc</td>
<td class="org-right">20220101.1527</td>
<td class="org-right">20221216.1238</td>
<td class="org-left">melpa</td>
</tr>
@@ -181,7 +181,7 @@ General key bindings and functions
<tr>
<td class="org-left">company</td>
<td class="org-right">20220103.351</td>
<td class="org-right">20221206.2122</td>
<td class="org-left">melpa</td>
</tr>
@@ -202,28 +202,28 @@ General key bindings and functions
<tr>
<td class="org-left">company-quickhelp</td>
<td class="org-right">20211115.1335</td>
<td class="org-right">20221212.534</td>
<td class="org-left">melpa</td>
</tr>
<tr>
<td class="org-left">company-web</td>
<td class="org-right">20180402.1155</td>
<td class="org-right">20220115.2146</td>
<td class="org-left">melpa</td>
</tr>
<tr>
<td class="org-left">counsel</td>
<td class="org-right">20211230.1909</td>
<td class="org-right">20221015.936</td>
<td class="org-left">melpa</td>
</tr>
<tr>
<td class="org-left">crdt</td>
<td class="org-right">0.2.7</td>
<td class="org-right">0.3.5</td>
<td class="org-left">elpa-gnu</td>
</tr>
@@ -237,14 +237,14 @@ General key bindings and functions
<tr>
<td class="org-left">dash</td>
<td class="org-right">20210826.1149</td>
<td class="org-right">20221013.836</td>
<td class="org-left">melpa</td>
</tr>
<tr>
<td class="org-left">dashboard</td>
<td class="org-right">20211221.2005</td>
<td class="org-right">20221206.1228</td>
<td class="org-left">melpa</td>
</tr>
@@ -272,7 +272,7 @@ General key bindings and functions
<tr>
<td class="org-left">diff-hl</td>
<td class="org-right">20211106.2353</td>
<td class="org-right">20221007.2147</td>
<td class="org-left">melpa</td>
</tr>
@@ -286,7 +286,7 @@ General key bindings and functions
<tr>
<td class="org-left">elisp-refs</td>
<td class="org-right">20211009.1531</td>
<td class="org-right">20220704.2141</td>
<td class="org-left">melpa</td>
</tr>
@@ -300,7 +300,7 @@ General key bindings and functions
<tr>
<td class="org-left">ess</td>
<td class="org-right">20211231.1746</td>
<td class="org-right">20221204.1348</td>
<td class="org-left">melpa</td>
</tr>
@@ -314,14 +314,14 @@ General key bindings and functions
<tr>
<td class="org-left">f</td>
<td class="org-right">20210624.1103</td>
<td class="org-right">20220911.711</td>
<td class="org-left">melpa</td>
</tr>
<tr>
<td class="org-left">flycheck</td>
<td class="org-right">20210825.1804</td>
<td class="org-right">20221213.107</td>
<td class="org-left">melpa</td>
</tr>
@@ -342,28 +342,28 @@ General key bindings and functions
<tr>
<td class="org-left">flyspell-correct</td>
<td class="org-right">20210724.1042</td>
<td class="org-right">20220520.63</td>
<td class="org-left">melpa</td>
</tr>
<tr>
<td class="org-left">flyspell-correct-ivy</td>
<td class="org-right">20210124.1143</td>
<td class="org-right">20220520.63</td>
<td class="org-left">melpa</td>
</tr>
<tr>
<td class="org-left">focus</td>
<td class="org-right">20191209.221</td>
<td class="org-right">20221016.1846</td>
<td class="org-left">melpa</td>
</tr>
<tr>
<td class="org-left">git-commit</td>
<td class="org-right">20220101.841</td>
<td class="org-right">20221127.2227</td>
<td class="org-left">melpa</td>
</tr>
@@ -377,21 +377,21 @@ General key bindings and functions
<tr>
<td class="org-left">gnuplot</td>
<td class="org-right">20220102.1637</td>
<td class="org-right">20221112.2049</td>
<td class="org-left">melpa</td>
</tr>
<tr>
<td class="org-left">helpful</td>
<td class="org-right">20211226.1843</td>
<td class="org-right">20221209.1743</td>
<td class="org-left">melpa</td>
</tr>
<tr>
<td class="org-left">ht</td>
<td class="org-right">20210119.741</td>
<td class="org-right">20221031.705</td>
<td class="org-left">melpa</td>
</tr>
@@ -405,7 +405,7 @@ General key bindings and functions
<tr>
<td class="org-left">hydra</td>
<td class="org-right">20220102.803</td>
<td class="org-right">20220910.1206</td>
<td class="org-left">melpa</td>
</tr>
@@ -419,14 +419,14 @@ General key bindings and functions
<tr>
<td class="org-left">iscroll</td>
<td class="org-right">20210128.1938</td>
<td class="org-right">20220612.31</td>
<td class="org-left">melpa</td>
</tr>
<tr>
<td class="org-left">ivy</td>
<td class="org-right">20211231.173</td>
<td class="org-right">20220926.125</td>
<td class="org-left">melpa</td>
</tr>
@@ -447,7 +447,7 @@ General key bindings and functions
<tr>
<td class="org-left">js2-mode</td>
<td class="org-right">20211229.135</td>
<td class="org-right">20221028.1819</td>
<td class="org-left">melpa</td>
</tr>
@@ -468,7 +468,7 @@ General key bindings and functions
<tr>
<td class="org-left">ledger-mode</td>
<td class="org-right">20211214.1449</td>
<td class="org-right">20220623.1125</td>
<td class="org-left">melpa</td>
</tr>
@@ -482,21 +482,21 @@ General key bindings and functions
<tr>
<td class="org-left">magit</td>
<td class="org-right">20220126.1645</td>
<td class="org-right">20221208.1848</td>
<td class="org-left">melpa</td>
</tr>
<tr>
<td class="org-left">magit-section</td>
<td class="org-right">20220101.841</td>
<td class="org-right">20221127.2227</td>
<td class="org-left">melpa</td>
</tr>
<tr>
<td class="org-left">markdown-mode</td>
<td class="org-right">20211022.55</td>
<td class="org-right">20221210.348</td>
<td class="org-left">melpa</td>
</tr>
@@ -510,14 +510,14 @@ General key bindings and functions
<tr>
<td class="org-left">mu4e-maildirs-extension</td>
<td class="org-right">20201028.921</td>
<td class="org-right">20220517.1852</td>
<td class="org-left">melpa</td>
</tr>
<tr>
<td class="org-left">multiple-cursors</td>
<td class="org-right">20211112.2223</td>
<td class="org-right">20221126.743</td>
<td class="org-left">melpa</td>
</tr>
@@ -531,14 +531,14 @@ General key bindings and functions
<tr>
<td class="org-left">org</td>
<td class="org-right">9.5.2</td>
<td class="org-right">9.6</td>
<td class="org-left">elpa-gnu</td>
</tr>
<tr>
<td class="org-left">org-appear</td>
<td class="org-right">20211202.604</td>
<td class="org-right">20220617.2355</td>
<td class="org-left">melpa</td>
</tr>
@@ -559,7 +559,7 @@ General key bindings and functions
<tr>
<td class="org-left">org-contrib</td>
<td class="org-right">0.3</td>
<td class="org-right">0.4.1</td>
<td class="org-left">elpa-nongnu</td>
</tr>
@@ -580,21 +580,21 @@ General key bindings and functions
<tr>
<td class="org-left">org-fragtog</td>
<td class="org-right">20220106.758</td>
<td class="org-right">20220714.2146</td>
<td class="org-left">melpa</td>
</tr>
<tr>
<td class="org-left">orgit</td>
<td class="org-right">20210620.1943</td>
<td class="org-right">20221127.2228</td>
<td class="org-left">melpa</td>
</tr>
<tr>
<td class="org-left">org-ref</td>
<td class="org-right">20220101.1941</td>
<td class="org-right">20221129.1925</td>
<td class="org-left">melpa</td>
</tr>
@@ -627,9 +627,16 @@ General key bindings and functions
</tr>
<tr>
<td class="org-left">ox-pandoc</td>
<td class="org-right">20220705.1036</td>
<td class="org-left">melpa</td>
</tr>
<tr>
<td class="org-left">ox-reveal</td>
<td class="org-right">20220410.1533</td>
<td class="org-right">20221127.814</td>
<td class="org-left">melpa</td>
</tr>
@@ -650,35 +657,35 @@ General key bindings and functions
<tr>
<td class="org-left">parsebib</td>
<td class="org-right">20211208.2335</td>
<td class="org-right">20221007.1402</td>
<td class="org-left">melpa</td>
</tr>
<tr>
<td class="org-left">pdf-tools</td>
<td class="org-right">20220103.308</td>
<td class="org-right">20221202.1104</td>
<td class="org-left">melpa</td>
</tr>
<tr>
<td class="org-left">persist</td>
<td class="org-right">0.4</td>
<td class="org-right">0.5</td>
<td class="org-left">elpa-gnu</td>
</tr>
<tr>
<td class="org-left">pfuture</td>
<td class="org-right">20211229.1513</td>
<td class="org-right">20220913.1401</td>
<td class="org-left">melpa</td>
</tr>
<tr>
<td class="org-left">php-mode</td>
<td class="org-right">20210808.1745</td>
<td class="org-right">20221112.1616</td>
<td class="org-left">melpa</td>
</tr>
@@ -692,14 +699,14 @@ General key bindings and functions
<tr>
<td class="org-left">polymode</td>
<td class="org-right">20211124.913</td>
<td class="org-right">20220820.163</td>
<td class="org-left">melpa</td>
</tr>
<tr>
<td class="org-left">popup</td>
<td class="org-right">20211231.1823</td>
<td class="org-right">20220927.161</td>
<td class="org-left">melpa</td>
</tr>
@@ -713,21 +720,21 @@ General key bindings and functions
<tr>
<td class="org-left">pos-tip</td>
<td class="org-right">20191227.1356</td>
<td class="org-right">20220715.102</td>
<td class="org-left">melpa</td>
</tr>
<tr>
<td class="org-left">powershell</td>
<td class="org-right">20220103.925</td>
<td class="org-right">20220805.1712</td>
<td class="org-left">melpa</td>
</tr>
<tr>
<td class="org-left">pythonic</td>
<td class="org-right">20210122.1247</td>
<td class="org-right">20220723.1741</td>
<td class="org-left">melpa</td>
</tr>
@@ -741,7 +748,7 @@ General key bindings and functions
<tr>
<td class="org-left">rainbow-mode</td>
<td class="org-right">1.0.5</td>
<td class="org-right">1.0.6</td>
<td class="org-left">elpa-gnu</td>
</tr>
@@ -755,14 +762,14 @@ General key bindings and functions
<tr>
<td class="org-left">s</td>
<td class="org-right">20210616.619</td>
<td class="org-right">20220902.1511</td>
<td class="org-left">melpa</td>
</tr>
<tr>
<td class="org-left">spacemacs-theme</td>
<td class="org-right">20210924.122</td>
<td class="org-right">20221103.1406</td>
<td class="org-left">melpa</td>
</tr>
@@ -797,14 +804,14 @@ General key bindings and functions
<tr>
<td class="org-left">string-inflection</td>
<td class="org-right">20210918.419</td>
<td class="org-right">20220910.1306</td>
<td class="org-left">melpa</td>
</tr>
<tr>
<td class="org-left">swiper</td>
<td class="org-right">20210919.1221</td>
<td class="org-right">20220430.2247</td>
<td class="org-left">melpa</td>
</tr>
@@ -818,28 +825,28 @@ General key bindings and functions
<tr>
<td class="org-left">transient</td>
<td class="org-right">20220104.1601</td>
<td class="org-right">20221202.1727</td>
<td class="org-left">melpa</td>
</tr>
<tr>
<td class="org-left">treemacs</td>
<td class="org-right">20220104.1302</td>
<td class="org-right">20221107.2105</td>
<td class="org-left">melpa</td>
</tr>
<tr>
<td class="org-left">treemacs-magit</td>
<td class="org-right">20211010.1005</td>
<td class="org-right">20220917.1026</td>
<td class="org-left">melpa</td>
</tr>
<tr>
<td class="org-left">use-package</td>
<td class="org-right">20210207.1926</td>
<td class="org-right">20221209.2013</td>
<td class="org-left">melpa</td>
</tr>
@@ -853,14 +860,14 @@ General key bindings and functions
<tr>
<td class="org-left">visual-fill-column</td>
<td class="org-right">20211118.33</td>
<td class="org-right">20220519.1959</td>
<td class="org-left">melpa</td>
</tr>
<tr>
<td class="org-left">vterm</td>
<td class="org-right">20211226.817</td>
<td class="org-right">20221118.1354</td>
<td class="org-left">melpa</td>
</tr>
@@ -874,21 +881,21 @@ General key bindings and functions
<tr>
<td class="org-left">web-mode</td>
<td class="org-right">20220104.1504</td>
<td class="org-right">20221012.8</td>
<td class="org-left">melpa</td>
</tr>
<tr>
<td class="org-left">which-key</td>
<td class="org-right">20220102.1433</td>
<td class="org-right">20220811.1616</td>
<td class="org-left">melpa</td>
</tr>
<tr>
<td class="org-left">with-editor</td>
<td class="org-right">20220101.1316</td>
<td class="org-right">20221127.2243</td>
<td class="org-left">melpa</td>
</tr>
@@ -902,7 +909,7 @@ General key bindings and functions
<tr>
<td class="org-left">yasnippet-snippets</td>
<td class="org-right">20210910.1959</td>
<td class="org-right">20220713.1234</td>
<td class="org-left">melpa</td>
</tr>
</tbody>

139
README.org
View File

@@ -100,124 +100,125 @@ echo -e "$pkg_custom\n$pkg_elpagnu\n$pkg_elpanongnu\n$pkg_melpa" | sort | column
#+RESULTS:
| PACKAGE_____________________ | VERSION______ | REPO_______ |
| ace-window | 20200606.1259 | melpa |
| ace-window | 20220911.358 | melpa |
| adaptive-wrap | 0.8 | elpa-gnu |
| all-the-icons | 20211225.506 | melpa |
| all-the-icons | 20220929.2303 | melpa |
| amx | 20210305.118 | melpa |
| anaconda-mode | 20211122.817 | melpa |
| async | 20210823.528 | melpa |
| avy | 20220102.805 | melpa |
| anaconda-mode | 20220922.741 | melpa |
| async | 20221217.649 | melpa |
| avy | 20220910.1936 | melpa |
| awesome-tray | 4.2 | custom |
| biblio | 20210418.406 | melpa |
| biblio-core | 20210418.406 | melpa |
| bibtex-completion | 20211019.1306 | melpa |
| bind-key | 20210210.1609 | melpa |
| citeproc | 20220101.1527 | melpa |
| bibtex-completion | 20221024.857 | melpa |
| bind-key | 20221209.2013 | melpa |
| citeproc | 20221216.1238 | melpa |
| cl-libify | 20181130.23 | melpa |
| company | 20220103.351 | melpa |
| company | 20221206.2122 | melpa |
| company-anaconda | 20200404.1859 | melpa |
| company-ledger | 20210910.25 | melpa |
| company-quickhelp | 20211115.1335 | melpa |
| company-web | 20180402.1155 | melpa |
| counsel | 20211230.1909 | melpa |
| crdt | 0.2.7 | elpa-gnu |
| company-quickhelp | 20221212.534 | melpa |
| company-web | 20220115.2146 | melpa |
| counsel | 20221015.936 | melpa |
| crdt | 0.3.5 | elpa-gnu |
| ctable | 20210128.629 | melpa |
| dash | 20210826.1149 | melpa |
| dashboard | 20211221.2005 | melpa |
| dash | 20221013.836 | melpa |
| dashboard | 20221206.1228 | melpa |
| deft | 20210707.1633 | melpa |
| delight | 1.7 | elpa-gnu |
| dialog | 0.2 | custom |
| diff-hl | 20211106.2353 | melpa |
| diff-hl | 20221007.2147 | melpa |
| dim | 20160818.949 | melpa |
| elisp-refs | 20211009.1531 | melpa |
| elisp-refs | 20220704.2141 | melpa |
| emojify | 20210108.1111 | melpa |
| ess | 20211231.1746 | melpa |
| ess | 20221204.1348 | melpa |
| ess-R-data-view | 20130509.1158 | melpa |
| f | 20210624.1103 | melpa |
| flycheck | 20210825.1804 | melpa |
| f | 20220911.711 | melpa |
| flycheck | 20221213.107 | melpa |
| flycheck-ledger | 20200304.2204 | melpa |
| flycheck-pos-tip | 20200516.16 | melpa |
| flyspell-correct | 20210724.1042 | melpa |
| flyspell-correct-ivy | 20210124.1143 | melpa |
| focus | 20191209.221 | melpa |
| git-commit | 20220101.841 | melpa |
| flyspell-correct | 20220520.63 | melpa |
| flyspell-correct-ivy | 20220520.63 | melpa |
| focus | 20221016.1846 | melpa |
| git-commit | 20221127.2227 | melpa |
| git-messenger | 20201202.1637 | melpa |
| gnuplot | 20220102.1637 | melpa |
| helpful | 20211226.1843 | melpa |
| ht | 20210119.741 | melpa |
| gnuplot | 20221112.2049 | melpa |
| helpful | 20221209.1743 | melpa |
| ht | 20221031.705 | melpa |
| htmlize | 20210825.215 | melpa |
| hydra | 20220102.803 | melpa |
| hydra | 20220910.1206 | melpa |
| indent-guide | 20210115.4 | melpa |
| iscroll | 20210128.1938 | melpa |
| ivy | 20211231.173 | melpa |
| iscroll | 20220612.31 | melpa |
| ivy | 20220926.125 | melpa |
| ivy-bibtex | 20210927.1205 | melpa |
| ivy-rich | 20210409.931 | melpa |
| js2-mode | 20211229.135 | melpa |
| js2-mode | 20221028.1819 | melpa |
| key-chord | 20201222.203 | melpa |
| langtool | 20200529.23 | melpa |
| ledger-mode | 20211214.1449 | melpa |
| ledger-mode | 20220623.1125 | melpa |
| lv | 20200507.1518 | melpa |
| magit | 20220126.1645 | melpa |
| magit-section | 20220101.841 | melpa |
| markdown-mode | 20211022.55 | melpa |
| magit | 20221208.1848 | melpa |
| magit-section | 20221127.2227 | melpa |
| markdown-mode | 20221210.348 | melpa |
| memoize | 20200103.2036 | melpa |
| mu4e-maildirs-extension | 20201028.921 | melpa |
| multiple-cursors | 20211112.2223 | melpa |
| mu4e-maildirs-extension | 20220517.1852 | melpa |
| multiple-cursors | 20221126.743 | melpa |
| ob-async | 20210428.2052 | melpa |
| org | 9.5.2 | elpa-gnu |
| org-appear | 20211202.604 | melpa |
| org | 9.6 | elpa-gnu |
| org-appear | 20220617.2355 | melpa |
| org-brain | 20210706.1519 | melpa |
| org-cliplink | 20201126.102 | melpa |
| org-contrib | 0.3 | elpa-nongnu |
| org-contrib | 0.4.1 | elpa-nongnu |
| org-drill | 20210427.2003 | melpa |
| org-fancy-priorities | 20210830.1657 | melpa |
| org-fragtog | 20220106.758 | melpa |
| orgit | 20210620.1943 | melpa |
| org-ref | 20220101.1941 | melpa |
| org-fragtog | 20220714.2146 | melpa |
| orgit | 20221127.2228 | melpa |
| org-ref | 20221129.1925 | melpa |
| org-sticky-header | 20201223.143 | melpa |
| org-superstar | 20210915.1934 | melpa |
| org-table-sticky-header | 20190924.506 | melpa |
| ov | 20200326.1042 | melpa |
| ox-reveal | 20220410.1533 | melpa |
| ox-pandoc | 20220705.1036 | melpa |
| ox-reveal | 20221127.814 | melpa |
| ox-tufte | 20160926.1607 | melpa |
| page-break-lines | 20210104.2224 | melpa |
| parsebib | 20211208.2335 | melpa |
| pdf-tools | 20220103.308 | melpa |
| persist | 0.4 | elpa-gnu |
| pfuture | 20211229.1513 | melpa |
| php-mode | 20210808.1745 | melpa |
| parsebib | 20221007.1402 | melpa |
| pdf-tools | 20221202.1104 | melpa |
| persist | 0.5 | elpa-gnu |
| pfuture | 20220913.1401 | melpa |
| php-mode | 20221112.1616 | melpa |
| plantuml-mode | 20191102.2056 | melpa |
| polymode | 20211124.913 | melpa |
| popup | 20211231.1823 | melpa |
| polymode | 20220820.163 | melpa |
| popup | 20220927.161 | melpa |
| popwin | 20210215.1849 | melpa |
| pos-tip | 20191227.1356 | melpa |
| powershell | 20220103.925 | melpa |
| pythonic | 20210122.1247 | melpa |
| pos-tip | 20220715.102 | melpa |
| powershell | 20220805.1712 | melpa |
| pythonic | 20220723.1741 | melpa |
| queue | 0.2 | elpa-gnu |
| rainbow-mode | 1.0.5 | elpa-gnu |
| rainbow-mode | 1.0.6 | elpa-gnu |
| restart-emacs | 20201127.1425 | melpa |
| s | 20210616.619 | melpa |
| spacemacs-theme | 20210924.122 | melpa |
| s | 20220902.1511 | melpa |
| spacemacs-theme | 20221103.1406 | melpa |
| sphinx-doc | 20210213.125 | melpa |
| sql-indent | 1.6 | elpa-gnu |
| srefactor | 20180703.181 | melpa |
| stickyfunc-enhance | 20150429.1814 | melpa |
| string-inflection | 20210918.419 | melpa |
| swiper | 20210919.1221 | melpa |
| string-inflection | 20220910.1306 | melpa |
| swiper | 20220430.2247 | melpa |
| systemd | 20210209.2052 | melpa |
| transient | 20220104.1601 | melpa |
| treemacs | 20220104.1302 | melpa |
| treemacs-magit | 20211010.1005 | melpa |
| use-package | 20210207.1926 | melpa |
| transient | 20221202.1727 | melpa |
| treemacs | 20221107.2105 | melpa |
| treemacs-magit | 20220917.1026 | melpa |
| use-package | 20221209.2013 | melpa |
| virtual-auto-fill | 20200906.2038 | melpa |
| visual-fill-column | 20211118.33 | melpa |
| vterm | 20211226.817 | melpa |
| visual-fill-column | 20220519.1959 | melpa |
| vterm | 20221118.1354 | melpa |
| web-completion-data | 20160318.848 | melpa |
| web-mode | 20220104.1504 | melpa |
| which-key | 20220102.1433 | melpa |
| with-editor | 20220101.1316 | melpa |
| web-mode | 20221012.8 | melpa |
| which-key | 20220811.1616 | melpa |
| with-editor | 20221127.2243 | melpa |
| yasnippet | 20200604.246 | melpa |
| yasnippet-snippets | 20210910.1959 | melpa |
| yasnippet-snippets | 20220713.1234 | melpa |
* Information
:PROPERTIES:

12
lisp/ace-window/ace-window-pkg.el Normal file
View File

@@ -0,0 +1,12 @@
(define-package "ace-window" "20220911.358" "Quickly switch windows."
'((avy "0.5.0"))
:commit "77115afc1b0b9f633084cf7479c767988106c196" :authors
'(("Oleh Krehel" . "ohwoeowho@gmail.com"))
:maintainer
'("Oleh Krehel" . "ohwoeowho@gmail.com")
:keywords
'("window" "location")
:url "https://github.com/abo-abo/ace-window")
;; Local Variables:
;; no-byte-compile: t
;; End:

64
lisp/ace-window/ace-window-posframe.el Normal file
View File

@@ -0,0 +1,64 @@
;;; ace-window-posframe.el --- posframe support for ace-window -*- lexical-binding: t -*-
;; Copyright (C) 2015-2022 Free Software Foundation, Inc.
(require 'ace-window)
;; Suppress warnings
(declare-function posframe-poshandler-window-center "ext:posframe")
(declare-function posframe-show "ext:posframe")
(declare-function posframe-hide "ext:posframe")
(declare-function posframe-workable-p "ext:posframe")
(defvar aw--posframe-frames '())
(defvar aw-posframe-position-handler #'posframe-poshandler-window-center)
(defun aw--lead-overlay-posframe (path leaf)
(let* ((wnd (cdr leaf))
(str (format "%s" (apply #'string path)))
;; It's important that buffer names are not unique across
;; multiple invocations: posframe becomes very slow when
;; creating new frames, and so being able to reuse old ones
;; makes a huge difference. What defines "able to reuse" is
;; something like: a frame exists which hasn't been deleted
;; (with posframe-delete) and has the same configuration as
;; the requested new frame.
(bufname (format " *aw-posframe-buffer-%s*" path)))
(with-selected-window wnd
(push bufname aw--posframe-frames)
(posframe-show bufname
:string str
:poshandler aw-posframe-position-handler
:font (face-font 'aw-leading-char-face)
:foreground-color (face-foreground 'aw-leading-char-face nil t)
:background-color (face-background 'aw-leading-char-face nil t)))))
(defun aw--remove-leading-chars-posframe ()
;; Hide rather than delete. See aw--lead-overlay-posframe for why.
(mapc #'posframe-hide aw--posframe-frames)
(setq aw--posframe-frames nil))
(defun ace-window-posframe-enable ()
(unless (and (require 'posframe nil t) (posframe-workable-p))
(error "Posframe is not workable"))
(setq aw--lead-overlay-fn #'aw--lead-overlay-posframe)
(setq aw--remove-leading-chars-fn #'aw--remove-leading-chars-posframe))
(defun ace-window-posframe-disable ()
(setq aw--lead-overlay-fn #'aw--lead-overlay)
(setq aw--remove-leading-chars-fn #'aw--remove-leading-chars))
;;;###autoload
(define-minor-mode ace-window-posframe-mode
"Minor mode for showing the ace window key with child frames."
:global t
:require 'ace-window
:group 'ace-window
:init-value nil
(if ace-window-posframe-mode
(ace-window-posframe-enable)
(ace-window-posframe-disable)))
(provide 'ace-window-posframe)

17
lisp/ace-window.el → lisp/ace-window/ace-window.el
View File

@@ -1,12 +1,10 @@
;;; ace-window.el --- Quickly switch windows. -*- lexical-binding: t -*-
;; Copyright (C) 2015-2020 Free Software Foundation, Inc.
;; Copyright (C) 2015-2022 Free Software Foundation, Inc.
;; Author: Oleh Krehel <ohwoeowho@gmail.com>
;; Maintainer: Oleh Krehel <ohwoeowho@gmail.com>
;; URL: https://github.com/abo-abo/ace-window
;; Package-Version: 20200606.1259
;; Package-Commit: c7cb315c14e36fded5ac4096e158497ae974bec9
;; Version: 0.10.0
;; Package-Requires: ((avy "0.5.0"))
;; Keywords: window, location
@@ -409,6 +407,15 @@ LEAF is (PT . WND)."
(overlay-put ol 'window wnd)
(push ol avy--overlays-lead)))))
(defvar aw--lead-overlay-fn #'aw--lead-overlay
"Function used to display the lead chars.")
(defun aw--remove-leading-chars ()
(avy--remove-leading-chars))
(defvar aw--remove-leading-chars-fn #'aw--remove-leading-chars
"Function used to cleanup lead chars.")
(defun aw--make-backgrounds (wnd-list)
"Create a dim background overlay for each window on WND-LIST."
(when aw-background
@@ -573,8 +580,8 @@ Amend MODE-LINE to the mode line for the duration of the selection."
(if (and ace-window-display-mode
(null aw-display-mode-overlay))
(lambda (_path _leaf))
#'aw--lead-overlay)
#'avy--remove-leading-chars)))
aw--lead-overlay-fn)
aw--remove-leading-chars-fn)))
(if (eq res 'exit)
(setq aw-action nil)
(or (cdr res)

2
lisp/adaptive-wrap/adaptive-wrap-pkg.el
View File

@@ -1,2 +1,2 @@
;; Generated package description from adaptive-wrap.el -*- no-byte-compile: t -*-
(define-package "adaptive-wrap" "0.8" "Smart line-wrapping with wrap-prefix" 'nil :url "https://elpa.gnu.org/packages/adaptive-wrap.html" :authors '(("Stephen Berman" . "stephen.berman@gmx.net") ("Stefan Monnier" . "monnier@iro.umontreal.ca")) :maintainer '("Stephen Berman" . "stephen.berman@gmx.net"))
(define-package "adaptive-wrap" "0.8" "Smart line-wrapping with wrap-prefix" 'nil :commit "026c35f59174febab2bcdb3c50fb8344c248671c" :url "https://elpa.gnu.org/packages/adaptive-wrap.html" :authors '(("Stephen Berman" . "stephen.berman@gmx.net") ("Stefan Monnier" . "monnier@iro.umontreal.ca")) :maintainer '(("Stephen Berman" . "stephen.berman@gmx.net") ("Stefan Monnier" . "monnier@iro.umontreal.ca")))

4
lisp/all-the-icons/all-the-icons-pkg.el
View File

@@ -1,6 +1,6 @@
(define-package "all-the-icons" "20211225.506" "A library for inserting Developer icons"
(define-package "all-the-icons" "20220929.2303" "A library for inserting Developer icons"
'((emacs "24.3"))
:commit "6d48bc9e970ab559bc35a125c55fd83732595706" :authors
:commit "51bf77da1ebc3c199dfc11f54c0dce67559f5f40" :authors
'(("Dominic Charlesworth" . "dgc336@gmail.com"))
:maintainer
'("Dominic Charlesworth" . "dgc336@gmail.com")

107
lisp/all-the-icons/all-the-icons.el
View File

@@ -120,6 +120,11 @@
:group 'all-the-icons
:type 'number)
(defcustom all-the-icons-fonts-subdirectory nil
"The subdirectory within the system fonts folder where the icons are installed."
:group 'all-the-icons
:type 'directory)
(defvar all-the-icons-font-families '() "List of defined icon font families.")
(defvar all-the-icons-font-names '() "List of defined font file names this package was built with.")
@@ -136,6 +141,8 @@
("babelrc" all-the-icons-fileicon "babel" :face all-the-icons-yellow)
("bashrc" all-the-icons-alltheicon "script" :height 0.9 :face all-the-icons-dpink)
("bowerrc" all-the-icons-alltheicon "bower" :height 1.0 :v-adjust 0.0 :face all-the-icons-silver)
("cr" all-the-icons-fileicon "crystal" :v-adjust 0.0 :face all-the-icons-yellow)
("ecr" all-the-icons-fileicon "crystal" :v-adjust 0.0 :face all-the-icons-yellow)
("ini" all-the-icons-octicon "settings" :v-adjust 0.0 :face all-the-icons-yellow)
("eslintignore" all-the-icons-fileicon "eslint" :height 0.9 :face all-the-icons-purple)
("eslint" all-the-icons-fileicon "eslint" :height 0.9 :face all-the-icons-lpurple)
@@ -151,6 +158,7 @@
;; ?
("pkg" all-the-icons-octicon "package" :v-adjust 0.0 :face all-the-icons-dsilver)
("rpm" all-the-icons-octicon "package" :v-adjust 0.0 :face all-the-icons-dsilver)
("pkgbuild" all-the-icons-octicon "package" :v-adjust 0.0 :face all-the-icons-dsilver)
("elc" all-the-icons-octicon "file-binary" :v-adjust 0.0 :face all-the-icons-dsilver)
("gz" all-the-icons-octicon "file-binary" :v-adjust 0.0 :face all-the-icons-lmaroon)
("zip" all-the-icons-octicon "file-zip" :v-adjust 0.0 :face all-the-icons-lmaroon)
@@ -171,10 +179,12 @@
("ex" all-the-icons-alltheicon "elixir" :face all-the-icons-lpurple :v-adjust -0.1 :height 0.9)
("exs" all-the-icons-alltheicon "elixir" :face all-the-icons-lred :v-adjust -0.1 :height 0.9)
("java" all-the-icons-alltheicon "java" :height 1.0 :face all-the-icons-purple)
("gradle" all-the-icons-fileicon "gradle" :height 1.0 :face all-the-icons-silver)
("ebuild" all-the-icons-fileicon "gentoo" :face all-the-icons-cyan)
("eclass" all-the-icons-fileicon "gentoo" :face all-the-icons-blue)
("go" all-the-icons-fileicon "go" :height 1.0 :face all-the-icons-blue)
("jl" all-the-icons-fileicon "julia" :face all-the-icons-purple :v-adjust 0.0)
("magik" all-the-icons-faicon "magic" :face all-the-icons-blue)
("matlab" all-the-icons-fileicon "matlab" :face all-the-icons-orange)
("nix" all-the-icons-fileicon "nix" :face all-the-icons-blue)
("pl" all-the-icons-alltheicon "perl" :face all-the-icons-lorange)
@@ -200,6 +210,9 @@
("rd" all-the-icons-fileicon "R" :face all-the-icons-lblue)
("rdx" all-the-icons-fileicon "R" :face all-the-icons-lblue)
("rsx" all-the-icons-fileicon "R" :face all-the-icons-lblue)
("svelte" all-the-icons-fileicon "svelte" :v-adjust 0.0 :face all-the-icons-red)
("gql" all-the-icons-fileicon "graphql" :face all-the-icons-dpink)
("graphql" all-the-icons-fileicon "graphql" :face all-the-icons-dpink)
;; There seems to be a a bug with this font icon which does not
;; let you propertise it without it reverting to being a lower
;; case phi
@@ -266,6 +279,7 @@
("js" all-the-icons-alltheicon "javascript" :height 1.0 :v-adjust 0.0 :face all-the-icons-yellow)
("es" all-the-icons-alltheicon "javascript" :height 1.0 :v-adjust 0.0 :face all-the-icons-yellow)
("jsx" all-the-icons-fileicon "jsx-2" :height 1.0 :v-adjust -0.1 :face all-the-icons-cyan-alt)
("tsx" all-the-icons-fileicon "tsx" :height 1.0 :v-adjust -0.1 :face all-the-icons-cyan-alt)
("njs" all-the-icons-alltheicon "nodejs" :height 1.2 :face all-the-icons-lgreen)
("vue" all-the-icons-fileicon "vue" :face all-the-icons-lgreen)
@@ -341,6 +355,8 @@
("fsscript" all-the-icons-fileicon "fsharp" :face all-the-icons-blue-alt)
;; zig
("zig" all-the-icons-fileicon "zig" :face all-the-icons-orange)
;; odin
("odin" all-the-icons-fileicon "odin" :height 1.1 :face all-the-icons-lblue)
;; File Types
("ico" all-the-icons-octicon "file-media" :v-adjust 0.0 :face all-the-icons-blue)
("png" all-the-icons-octicon "file-media" :v-adjust 0.0 :face all-the-icons-orange)
@@ -396,6 +412,7 @@
("xlsb" all-the-icons-fileicon "excel" :face all-the-icons-dgreen)
("xltx" all-the-icons-fileicon "excel" :face all-the-icons-dgreen)
("xltm" all-the-icons-fileicon "excel" :face all-the-icons-dgreen)
("ly" all-the-icons-faicon "music" :face all-the-icons-green)
;;
("key" all-the-icons-octicon "key" :v-adjust 0.0 :face all-the-icons-lblue)
("pem" all-the-icons-octicon "key" :v-adjust 0.0 :face all-the-icons-orange)
@@ -422,24 +439,24 @@ for performance sake.")
("^readme" all-the-icons-octicon "book" :height 1.0 :v-adjust 0.0 :face all-the-icons-lcyan)
;; Config
("^bower.json$" all-the-icons-alltheicon "bower" :height 1.0 :v-adjust 0.0 :face all-the-icons-lorange)
("nginx" all-the-icons-fileicon "nginx" :height 0.9 :face all-the-icons-dgreen)
("apache" all-the-icons-alltheicon "apache" :height 0.9 :face all-the-icons-dgreen)
("nginx$" all-the-icons-fileicon "nginx" :height 0.9 :face all-the-icons-dgreen)
("apache$" all-the-icons-alltheicon "apache" :height 0.9 :face all-the-icons-dgreen)
;; C
("^Makefile$" all-the-icons-fileicon "gnu" :face all-the-icons-dorange)
("^CMakeLists.txt$" all-the-icons-fileicon "cmake" :face all-the-icons-red)
("^CMakeCache.txt$" all-the-icons-fileicon "cmake" :face all-the-icons-blue)
("^meson.build$" all-the-icons-fileicon "meson" :face all-the-icons-purple)
("^meson_options.txt$" all-the-icons-fileicon "meson" :face all-the-icons-purple)
;; Docker
("^\\.?Dockerfile" all-the-icons-fileicon "dockerfile" :face all-the-icons-blue)
;; Homebrew
("^Brewfile$" all-the-icons-faicon "beer" :face all-the-icons-lsilver)
("\\.npmignore$" all-the-icons-fileicon "npm" :face all-the-icons-dred)
("^package.json$" all-the-icons-fileicon "npm" :face all-the-icons-red)
("^package.lock.json$" all-the-icons-fileicon "npm" :face all-the-icons-dred)
("^yarn\\.lock" all-the-icons-fileicon "yarn" :face all-the-icons-blue-alt)
;; ;; AWS
("^stack.*.json$" all-the-icons-alltheicon "aws" :face all-the-icons-orange)
("^serverless\\.yml$" all-the-icons-faicon "bolt" :v-adjust 0.0 :face all-the-icons-yellow)
;; lock files
@@ -448,11 +465,12 @@ for performance sake.")
;; Source Codes
("^mix.lock$" all-the-icons-alltheicon "elixir" :face all-the-icons-lyellow :v-adjust -0.1 :height 0.9)
("^Gemfile\\(\\.lock\\)?$" all-the-icons-alltheicon "ruby-alt" :face all-the-icons-red)
("_?test\\.rb$" all-the-icons-fileicon "test-ruby" :height 1.0 :v-adjust 0.0 :face all-the-icons-red)
("_?test_helper\\.rb$" all-the-icons-fileicon "test-ruby" :height 1.0 :v-adjust 0.0 :face all-the-icons-dred)
("_?spec\\.rb$" all-the-icons-fileicon "test-ruby" :height 1.0 :v-adjust 0.0 :face all-the-icons-red)
("_?spec_helper\\.rb$" all-the-icons-fileicon "test-ruby" :height 1.0 :v-adjust 0.0 :face all-the-icons-dred)
;; Ruby
("^Gemfile\\(\\.lock\\)?$" all-the-icons-alltheicon "ruby-alt" :face all-the-icons-red)
("_?test\\.rb$" all-the-icons-fileicon "test-ruby" :height 1.0 :v-adjust 0.0 :face all-the-icons-red)
("_?test_helper\\.rb$" all-the-icons-fileicon "test-ruby" :height 1.0 :v-adjust 0.0 :face all-the-icons-dred)
("_?spec\\.rb$" all-the-icons-fileicon "test-ruby" :height 1.0 :v-adjust 0.0 :face all-the-icons-red)
("_?spec_helper\\.rb$" all-the-icons-fileicon "test-ruby" :height 1.0 :v-adjust 0.0 :face all-the-icons-dred)
("-?spec\\.ts$" all-the-icons-fileicon "test-typescript" :height 1.0 :v-adjust 0.0 :face all-the-icons-blue)
("-?test\\.ts$" all-the-icons-fileicon "test-typescript" :height 1.0 :v-adjust 0.0 :face all-the-icons-blue)
@@ -467,19 +485,33 @@ for performance sake.")
;; Stylesheeting
("stylelint" all-the-icons-fileicon "stylelint" :face all-the-icons-lyellow)
;; JavaScript
("^package.json$" all-the-icons-fileicon "npm" :face all-the-icons-red)
("^package.lock.json$" all-the-icons-fileicon "npm" :face all-the-icons-dred)
("^yarn\\.lock" all-the-icons-fileicon "yarn" :face all-the-icons-blue-alt)
("\\.npmignore$" all-the-icons-fileicon "npm" :face all-the-icons-dred)
("^bower.json$" all-the-icons-alltheicon "bower" :height 1.0 :v-adjust 0.0 :face all-the-icons-lorange)
("^gulpfile" all-the-icons-alltheicon "gulp" :height 1.0 :face all-the-icons-lred)
("^gruntfile" all-the-icons-alltheicon "grunt" :height 1.0 :v-adjust -0.1 :face all-the-icons-lyellow)
("^webpack" all-the-icons-fileicon "webpack" :face all-the-icons-lblue)
;; Go
("^go.mod$" all-the-icons-fileicon "config-go" :height 1.0 :face all-the-icons-blue-alt)
("^go.work$" all-the-icons-fileicon "config-go" :height 1.0 :face all-the-icons-blue-alt)
;; Emacs
("bookmark" all-the-icons-octicon "bookmark" :height 1.1 :v-adjust 0.0 :face all-the-icons-lpink)
("^\\*scratch\\*$" all-the-icons-faicon "sticky-note" :face all-the-icons-lyellow)
("^\\*scratch.*" all-the-icons-faicon "sticky-note" :face all-the-icons-yellow)
("^\\*new-tab\\*$" all-the-icons-material "star" :face all-the-icons-cyan)
("^\\*new-tab\\*$" all-the-icons-material "star" :face all-the-icons-cyan)
("^\\." all-the-icons-octicon "gear" :v-adjust 0.0)
(".?" all-the-icons-faicon "file-o" :v-adjust 0.0 :face all-the-icons-dsilver)))
))
(defvar all-the-icons-default-file-icon
'(all-the-icons-faicon "file-o" :v-adjust 0.0 :face all-the-icons-dsilver))
(defvar all-the-icons-dir-icon-alist
'(
@@ -540,6 +572,8 @@ for performance sake.")
(emacs-lisp-mode all-the-icons-fileicon "elisp" :height 1.0 :v-adjust -0.1 :face all-the-icons-purple)
(circe-server-mode all-the-icons-faicon "commenting-o" :height 1.0 :v-adjust 0.0)
(circe-channel-mode all-the-icons-faicon "commenting-o" :height 1.0 :v-adjust 0.0)
(circe-query-mode all-the-icons-faicon "commenting-o" :height 1.0 :v-adjust 0.0)
(crystal-mode all-the-icons-fileicon "crystal" :v-adjust 0.0 :face all-the-icons-yellow)
(erc-mode all-the-icons-faicon "commenting-o" :height 1.0 :v-adjust 0.0)
(inferior-emacs-lisp-mode all-the-icons-fileicon "elisp" :height 1.0 :v-adjust -0.1 :face all-the-icons-lblue)
(dired-mode all-the-icons-octicon "file-directory" :v-adjust 0.0)
@@ -548,6 +582,7 @@ for performance sake.")
(slime-repl-mode all-the-icons-fileicon "clisp" :v-adjust -0.1 :face all-the-icons-orange)
(org-mode all-the-icons-fileicon "org" :v-adjust 0.0 :face all-the-icons-lgreen)
(typescript-mode all-the-icons-fileicon "typescript" :v-adjust -0.1 :face all-the-icons-blue-alt)
(typescript-tsx-mode all-the-icons-fileicon "tsx" :v-adjust -0.1 :face all-the-icons-cyan-alt)
(js-mode all-the-icons-alltheicon "javascript" :v-adjust -0.1 :face all-the-icons-yellow)
(js-jsx-mode all-the-icons-alltheicon "javascript" :v-adjust -0.1 :face all-the-icons-yellow)
(js2-mode all-the-icons-alltheicon "javascript" :v-adjust -0.1 :face all-the-icons-yellow)
@@ -576,6 +611,7 @@ for performance sake.")
(mu4e-headers-mode all-the-icons-octicon "mail" :v-adjust 0.0)
(mu4e-main-mode all-the-icons-octicon "mail" :v-adjust 0.0)
(mu4e-view-mode all-the-icons-octicon "mail-read" :v-adjust 0.0)
(sieve-mode all-the-icons-octicon "mail" :v-adjust 0.0)
(package-menu-mode all-the-icons-faicon "archive" :height 1.0 :v-adjust 0.0 :face all-the-icons-silver)
(paradox-menu-mode all-the-icons-faicon "archive" :height 1.0 :v-adjust 0.0 :face all-the-icons-silver)
(Custom-mode all-the-icons-octicon "settings" :v-adjust -0.1)
@@ -603,15 +639,20 @@ for performance sake.")
(docker-compose-mode all-the-icons-fileicon "dockerfile" :face all-the-icons-lblue)
(nxml-mode all-the-icons-faicon "file-code-o" :height 0.95 :face all-the-icons-lorange)
(json-mode all-the-icons-octicon "settings" :face all-the-icons-yellow)
(jsonian-mode all-the-icons-octicon "settings" :face all-the-icons-yellow)
(yaml-mode all-the-icons-octicon "settings" :v-adjust 0.0 :face all-the-icons-dyellow)
(elisp-byte-code-mode all-the-icons-octicon "file-binary" :v-adjust 0.0 :face all-the-icons-dsilver)
(archive-mode all-the-icons-octicon "file-zip" :v-adjust 0.0 :face all-the-icons-lmaroon)
(elm-mode all-the-icons-fileicon "elm" :face all-the-icons-blue)
(erlang-mode all-the-icons-alltheicon "erlang" :face all-the-icons-red :v-adjust -0.1 :height 0.9)
(elixir-mode all-the-icons-alltheicon "elixir" :face all-the-icons-lorange :v-adjust -0.1 :height 0.9)
(java-mode all-the-icons-alltheicon "java" :height 1.0 :face all-the-icons-purple)
(go-mode all-the-icons-fileicon "go" :height 1.0 :face all-the-icons-blue)
(java-mode all-the-icons-alltheicon "java" :height 1.0 :face all-the-icons-purple)
(go-mode all-the-icons-fileicon "go" :height 1.0 :face all-the-icons-blue)
(go-dot-mod-mode all-the-icons-fileicon "config-go" :height 1.0 :face all-the-icons-blue-alt)
(go-dot-work-mode all-the-icons-fileicon "config-go" :height 1.0 :face all-the-icons-blue-alt)
(graphql-mode all-the-icons-fileicon "graphql" :face all-the-icons-dpink)
(matlab-mode all-the-icons-fileicon "matlab" :face all-the-icons-orange)
(nix-mode all-the-icons-fileicon "nix" :face all-the-icons-blue)
(perl-mode all-the-icons-alltheicon "perl" :face all-the-icons-lorange)
(cperl-mode all-the-icons-alltheicon "perl" :face all-the-icons-lorange)
(php-mode all-the-icons-fileicon "php" :face all-the-icons-lsilver)
@@ -623,6 +664,7 @@ for performance sake.")
(scala-mode all-the-icons-alltheicon "scala" :face all-the-icons-red)
(scheme-mode all-the-icons-fileicon "scheme" :height 1.2 :face all-the-icons-red)
(swift-mode all-the-icons-alltheicon "swift" :height 1.0 :v-adjust -0.1 :face all-the-icons-green)
(svelte-mode all-the-icons-fileicon "svelte" :v-adjust 0.0 :face all-the-icons-red)
(c-mode all-the-icons-alltheicon "c-line" :face all-the-icons-blue)
(c++-mode all-the-icons-alltheicon "cplusplus-line" :v-adjust -0.2 :face all-the-icons-blue)
(csharp-mode all-the-icons-alltheicon "csharp-line" :face all-the-icons-dblue)
@@ -680,9 +722,15 @@ for performance sake.")
(hy-mode all-the-icons-fileicon "hy" :face all-the-icons-blue)
(glsl-mode all-the-icons-fileicon "vertex-shader" :face all-the-icons-green)
(zig-mode all-the-icons-fileicon "zig" :face all-the-icons-orange)
(odin-mode all-the-icons-fileicon "odin" :height 1.1 :face all-the-icons-lblue)
(pdf-view-mode all-the-icons-octicon "file-pdf" :v-adjust 0.0 :face all-the-icons-dred)
(elfeed-search-mode all-the-icons-faicon "rss-square" :face all-the-icons-orange)
(elfeed-show-mode all-the-icons-faicon "rss" :face all-the-icons-orange)))
(elfeed-show-mode all-the-icons-faicon "rss" :face all-the-icons-orange)
(lilypond-mode all-the-icons-faicon "music" :face all-the-icons-green)
(magik-session-mode all-the-icons-alltheicon "terminal" :face all-the-icons-blue)
(magik-cb-mode all-the-icons-faicon "book" :face all-the-icons-blue)
(meson-mode all-the-icons-fileicon "meson" :face all-the-icons-purple)
(man-common all-the-icons-fileicon "man-page" :face all-the-icons-blue)))
(defvar all-the-icons-url-alist
'(
@@ -873,6 +921,8 @@ Note: You want chevron, please use `all-the-icons-icon-for-dir-with-chevron'."
(args (cdr icon)))
(when arg-overrides (setq args (append `(,(car args)) arg-overrides (cdr args))))
(cond
((file-remote-p path)
(apply #'all-the-icons-octicon "terminal" (cdr args)))
((file-symlink-p path)
(apply #'all-the-icons-octicon "file-symlink-directory" (cdr args)))
((all-the-icons-dir-is-submodule path)
@@ -888,10 +938,11 @@ ARG-OVERRIDES should be a plist containining `:height',
`:v-adjust' or `:face' properties like in the normal icon
inserting functions."
(let* ((ext (file-name-extension file))
(icon (or (and ext
(icon (or (all-the-icons-match-to-alist file all-the-icons-regexp-icon-alist)
(and ext
(cdr (assoc (downcase ext)
all-the-icons-extension-icon-alist)))
(all-the-icons-match-to-alist file all-the-icons-regexp-icon-alist)))
all-the-icons-default-file-icon))
(args (cdr icon)))
(when arg-overrides (setq args (append `(,(car args)) arg-overrides (cdr args))))
(apply (car icon) args)))
@@ -952,7 +1003,12 @@ inserting functions."
;; Family Face Functions
(defun all-the-icons-icon-family-for-file (file)
"Get the icons font family for FILE."
(let ((icon (all-the-icons-match-to-alist file all-the-icons-regexp-icon-alist)))
(let* ((ext (file-name-extension file))
(icon (or (all-the-icons-match-to-alist file all-the-icons-regexp-icon-alist)
(and ext
(cdr (assoc (downcase ext)
all-the-icons-extension-icon-alist)))
all-the-icons-default-file-icon)))
(funcall (intern (format "%s-family" (car icon))))))
(defun all-the-icons-icon-family-for-mode (mode)
@@ -1050,10 +1106,13 @@ When PFX is non-nil, ignore the prompt and just install"
((member system-type '(gnu gnu/linux gnu/kfreebsd))
(concat (or (getenv "XDG_DATA_HOME")
(concat (getenv "HOME") "/.local/share"))
"/fonts/"))
"/fonts/"
all-the-icons-fonts-subdirectory))
;; Default MacOS install directory
((eq system-type 'darwin)
(concat (getenv "HOME") "/Library/Fonts/"))))
(concat (getenv "HOME")
"/Library/Fonts/"
all-the-icons-fonts-subdirectory))))
(known-dest? (stringp font-dest))
(font-dest (or font-dest (read-directory-name "Font installation directory: " "~/"))))

19
lisp/all-the-icons/data/data-fileicons.el
View File

@@ -1,6 +1,6 @@
(defvar all-the-icons-data/file-icon-alist
'(
( "1c" . "\xa5ea" )
( "1c-alt" . "\xea28" )
( "MJML" . "\xea6f" )
@@ -94,6 +94,16 @@
( "clisp" . "\xe972" )
( "composer" . "\xe683" )
( "config" . "\xf07c" )
( "config-coffeescript" . "\xeb18" )
( "config-go" . "\xeb12" )
( "config-haskell" . "\xeb14" )
( "config-js" . "\xeb1a" )
( "config-perl" . "\xeb19" )
( "config-python" . "\xeb15" )
( "config-react" . "\xeb16" )
( "config-ruby" . "\xeb17" )
( "config-rust" . "\xeb13" )
( "config-typescript" . "\xeb1b" )
( "coq" . "\xe95f" )
( "cordova" . "\xea11" )
( "cp" . "\xe942" )
@@ -257,7 +267,7 @@
( "maya" . "\xe9f6" )
( "mediawiki" . "\xe954" )
( "mercury" . "\xe994" )
( "meson" . "\xea54" )
( "meson" . "\xeafe" )
( "metal" . "\x4d" )
( "meteor" . "\xe6a5" )
( "microsoft-infopath" . "\xea35" )
@@ -302,6 +312,7 @@
( "objective-j" . "\xe99e" )
( "ocaml" . "\xe91a" )
( "octave" . "\xea33" )
( "odin" . "\eb36" )
( "onenote" . "\xe9eb" )
( "ooc" . "\xe9cb" )
( "opa" . "\x2601" )
@@ -415,6 +426,7 @@
( "stylus-orb" . "\x53" )
( "sublime" . "\xe986" )
( "sv" . "\xe9c3" )
( "svelte" . "\x33dc" )
( "svn" . "\xea17" )
( "swagger" . "\xea29" )
( "tag" . "\xf015" )
@@ -482,9 +494,8 @@
( "yui" . "\xea00" )
( "zbrush" . "\xe9f2" )
( "zephir" . "\xe9c7" )
("zig" . "\x7A")
( "zig" . "\x7A" )
( "zimpl" . "\xe9c8" )
)
)

4
lisp/anaconda-mode/anaconda-mode-pkg.el
View File

@@ -1,10 +1,10 @@
(define-package "anaconda-mode" "20211122.817" "Code navigation, documentation lookup and completion for Python"
(define-package "anaconda-mode" "20220922.741" "Code navigation, documentation lookup and completion for Python"
'((emacs "25.1")
(pythonic "0.1.0")
(dash "2.6.0")
(s "1.9")
(f "0.16.2"))
:commit "cbea0fb3182321d34ff93981c5a59f8dd72d82a5" :authors
:commit "ca8edbaa7662d97e4a4416ec9a8d743863303911" :authors
'(("Artem Malyshev" . "proofit404@gmail.com"))
:maintainer
'("Artem Malyshev" . "proofit404@gmail.com")

21
lisp/anaconda-mode/anaconda-mode.el
View File

@@ -337,15 +337,18 @@ called when `anaconda-mode-port' will be bound."
"-L" (format "%s:localhost:%s" (anaconda-mode-port) (anaconda-mode-port))
(format "%s@%s" (pythonic-remote-user) (pythonic-remote-host))
"-p" (number-to-string (or (pythonic-remote-port) 22)))
(start-process anaconda-mode-ssh-process-name
anaconda-mode-ssh-process-buffer
"ssh" "-nNT"
"-L" (format "%s:localhost:%s" (anaconda-mode-port) (anaconda-mode-port))
(if (pythonic-remote-user)
(format "%s@%s" (pythonic-remote-user) (pythonic-remote-host))
;; Asssume remote host is an ssh alias
(pythonic-remote-host))
"-p" (number-to-string (or (pythonic-remote-port) 22)))))
(apply 'start-process
anaconda-mode-ssh-process-name
anaconda-mode-ssh-process-buffer
"ssh" "-nNT"
"-L" (format "%s:localhost:%s" (anaconda-mode-port) (anaconda-mode-port))
(if (pythonic-remote-user)
(format "%s@%s" (pythonic-remote-user) (pythonic-remote-host))
;; Asssume remote host is an ssh alias
(pythonic-remote-host))
;; Pass in port only if it exists (might be included in ssh alias)
(when-let ((port (pythonic-remote-port)))
'("-p" (number-to-string port))))))
;; prevent race condition between tunnel setup and first use
(sleep-for anaconda-mode-tunnel-setup-sleep)
(set-process-query-on-exit-flag anaconda-mode-ssh-process nil))))

17
lisp/anaconda-mode/anaconda-mode.py
View File

@@ -2,7 +2,6 @@
from __future__ import print_function
import sys
import os
from distutils.version import LooseVersion
# CLI arguments.
@@ -105,9 +104,21 @@ if missing_dependencies:
import jedi
import service_factory
# Setup server.
assert LooseVersion(jedi.__version__) >= LooseVersion(jedi_dep[1]), 'Jedi version should be >= %s, current version: %s' % (jedi_dep[1], jedi.__version__)
# Setup server.
def is_jedi_dep_satisfied():
dep = jedi_dep[1].split('.')
jed = jedi.__version__.split('.')
for (d, j) in zip(dep, jed):
if int(d) < int(j):
return True
elif int(d) > int(j):
return False
return (len(dep) <= len(jed))
assert is_jedi_dep_satisfied(), 'Jedi version should be >= %s, current version: %s' % (jedi_dep[1], jedi.__version__)
if virtual_environment:
virtual_environment = jedi.create_environment(virtual_environment, safe=False)

32
lisp/async/async-bytecomp.el
View File

@@ -1,27 +1,25 @@
;;; async-bytecomp.el --- Compile elisp files asynchronously -*- lexical-binding: t -*-
;; Copyright (C) 2014-2019 Free Software Foundation, Inc.
;; Copyright (C) 2014-2022 Free Software Foundation, Inc.
;; Authors: John Wiegley <jwiegley@gmail.com>
;; Thierry Volpiatto <thierry.volpiatto@gmail.com>
;; Thierry Volpiatto <thievol@posteo.net>
;; Keywords: dired async byte-compile
;; X-URL: https://github.com/jwiegley/dired-async
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2, or (at
;; your option) any later version.
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;;
@@ -40,6 +38,7 @@
(require 'cl-lib)
(require 'async)
(require 'bytecomp)
(declare-function package-desc-name "package.el")
(declare-function package-desc-dir "package.el")
@@ -58,6 +57,9 @@ all packages are always compiled asynchronously."
(defvar async-byte-compile-log-file
(concat user-emacs-directory "async-bytecomp.log"))
(defvar async-bytecomp-load-variable-regexp "\\`load-path\\'"
"The variable used by `async-inject-variables' when (re)compiling async.")
;;;###autoload
(defun async-byte-recompile-directory (directory &optional quiet)
"Compile all *.el files in DIRECTORY asynchronously.
@@ -94,7 +96,7 @@ All *.elc files are systematically deleted before proceeding."
(async-start
`(lambda ()
(require 'bytecomp)
,(async-inject-variables "\\`\\(?:load-path\\'\\|byte-\\)")
,(async-inject-variables async-bytecomp-load-variable-regexp)
(let ((default-directory (file-name-as-directory ,directory))
error-data)
(add-to-list 'load-path default-directory)
@@ -191,7 +193,7 @@ Same as `byte-compile-file' but asynchronous."
(async-start
`(lambda ()
(require 'bytecomp)
,(async-inject-variables "\\`load-path\\'")
,(async-inject-variables async-bytecomp-load-variable-regexp)
(let ((default-directory ,(file-name-directory file)))
(add-to-list 'load-path default-directory)
(byte-compile-file ,file)

6
lisp/async/async-pkg.el
View File

@@ -1,9 +1,9 @@
(define-package "async" "20210823.528" "Asynchronous processing in Emacs"
(define-package "async" "20221217.649" "Asynchronous processing in Emacs"
'((emacs "24.4"))
:commit "fd7a9fca4a7bd0690e2e7e209397f493194e4f12" :authors
:commit "c4772bec684776e93f1b8d845b452dc850ee2315" :authors
'(("John Wiegley" . "jwiegley@gmail.com"))
:maintainer
'("John Wiegley" . "jwiegley@gmail.com")
'("Thierry Volpiatto" . "thievol@posteo.net")
:keywords
'("async")
:url "https://github.com/jwiegley/emacs-async")

96
lisp/async/async.el
View File

@@ -1,29 +1,29 @@
;;; async.el --- Asynchronous processing in Emacs -*- lexical-binding: t -*-
;; Copyright (C) 2012-2019 Free Software Foundation, Inc.
;; Copyright (C) 2012-2022 Free Software Foundation, Inc.
;; Author: John Wiegley <jwiegley@gmail.com>
;; Maintainer: Thierry Volpiatto <thievol@posteo.net>
;; Created: 18 Jun 2012
;; Version: 1.9.5
;; Version: 1.9.7
;; Package-Requires: ((emacs "24.4"))
;; Keywords: async
;; X-URL: https://github.com/jwiegley/emacs-async
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2, or (at
;; your option) any later version.
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
@@ -36,7 +36,7 @@
(defgroup async nil
"Simple asynchronous processing in Emacs"
:group 'emacs)
:group 'lisp)
(defcustom async-variables-noprops-function #'async--purecopy
"Default function to remove text properties in variables."
@@ -51,6 +51,16 @@
(defvar async-callback-value-set nil)
(defvar async-current-process nil)
(defvar async--procvar nil)
(defvar async-child-init nil
"Initialisation file for async child Emacs.
If defined this allows for an init file to setup the child Emacs. It
should not be your normal init.el as that would likely load more
things that you require. It should limit itself to ensuring paths have
been setup so any async code can load libraries you expect.")
;; For emacs<29 (only exists in emacs-29+).
(defvar print-symbols-bare)
(defun async--purecopy (object)
"Remove text properties in OBJECT.
@@ -206,7 +216,9 @@ It is intended to be used as follows:
(let (print-level
print-length
(print-escape-nonascii t)
(print-circle t))
(print-circle t)
;; Fix bug#153 in emacs-29 with symbol's positions.
(print-symbols-bare t))
(prin1 sexp (current-buffer))
;; Just in case the string we're sending might contain EOF
(encode-coding-region (point-min) (point-max) 'utf-8-auto)
@@ -225,19 +237,17 @@ It is intended to be used as follows:
"Called from the child Emacs process' command line."
;; Make sure 'message' and 'prin1' encode stuff in UTF-8, as parent
;; process expects.
(let ((coding-system-for-write 'utf-8-auto))
(let ((coding-system-for-write 'utf-8-auto)
(args-left command-line-args-left))
(setq async-in-child-emacs t
debug-on-error async-debug)
(if debug-on-error
debug-on-error async-debug
command-line-args-left nil)
(condition-case-unless-debug err
(prin1 (funcall
(async--receive-sexp (unless async-send-over-pipe
command-line-args-left))))
(condition-case err
(prin1 (funcall
(async--receive-sexp (unless async-send-over-pipe
command-line-args-left))))
(error
(prin1 (list 'async-signal err)))))))
args-left))))
(error
(prin1 (list 'async-signal err))))))
(defun async-ready (future)
"Query a FUTURE to see if it is ready.
@@ -307,6 +317,20 @@ Can be one of \"-Q\" or \"-q\".
Default is \"-Q\" but it is sometimes useful to use \"-q\" to have a
enhanced config or some more variables loaded.")
(defun async--emacs-program-args (&optional sexp)
"Return a list of arguments for invoking the child Emacs."
;; Using `locate-library' ensure we use the right file
;; when the .elc have been deleted.
(let ((args (list async-quiet-switch "-l" (locate-library "async"))))
(when async-child-init
(setq args (append args (list "-l" async-child-init))))
(append args (list "-batch" "-f" "async-batch-invoke"
(if sexp
(with-temp-buffer
(async--insert-sexp (list 'quote sexp))
(buffer-string))
"<none>")))))
;;;###autoload
(defun async-start (start-func &optional finish-func)
"Execute START-FUNC (often a lambda) in a subordinate Emacs process.
@@ -370,21 +394,13 @@ returns nil. It can still be useful, however, as an argument to
;; Subordinate Emacs will send text encoded in UTF-8.
(coding-system-for-read 'utf-8-auto))
(setq async--procvar
(async-start-process
"emacs" (file-truename
(expand-file-name invocation-name
invocation-directory))
finish-func
async-quiet-switch "-l"
;; Using `locate-library' ensure we use the right file
;; when the .elc have been deleted.
(locate-library "async")
"-batch" "-f" "async-batch-invoke"
(if async-send-over-pipe
"<none>"
(with-temp-buffer
(async--insert-sexp (list 'quote sexp))
(buffer-string)))))
(apply 'async-start-process
"emacs" (file-truename
(expand-file-name invocation-name
invocation-directory))
finish-func
(async--emacs-program-args (if (not async-send-over-pipe) sexp))))
(if async-send-over-pipe
(async--transmit-sexp async--procvar (list 'quote sexp)))
async--procvar))

182
lisp/async/dired-async.el
View File

@@ -3,25 +3,23 @@
;; Copyright (C) 2012-2019 Free Software Foundation, Inc.
;; Authors: John Wiegley <jwiegley@gmail.com>
;; Thierry Volpiatto <thierry.volpiatto@gmail.com>
;; Thierry Volpiatto <thievol@posteo.net>
;; Keywords: dired async network
;; X-URL: https://github.com/jwiegley/dired-async
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2, or (at
;; your option) any later version.
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
@@ -70,6 +68,19 @@ Should take same args as `message'."
:risky t
:type 'sexp)
(defcustom dired-async-skip-fast nil
"If non-nil, skip async for fast operations.
Same device renames and copying and renaming files smaller than
`dired-async-small-file-max' are considered fast."
:risky t
:type 'boolean)
(defcustom dired-async-small-file-max 5000000
"Files smaller than this in bytes are considered fast to copy
or rename for `dired-async-skip-fast'."
:risky t
:type 'integer)
(defface dired-async-message
'((t (:foreground "yellow")))
"Face used for mode-line message.")
@@ -106,8 +117,7 @@ Should take same args as `message'."
(defun dired-async-processes ()
(cl-loop for p in (process-list)
when (cl-loop for c in (process-command p) thereis
(string= "async-batch-invoke" c))
when (process-get p 'dired-async-process)
collect p))
(defun dired-async-kill-process ()
@@ -176,6 +186,62 @@ Should take same args as `message'."
(buffer-name b)) b))))
(when buf (kill-buffer buf))))))
(defsubst dired-async--directory-p (attributes)
"Return non-nil if ATTRIBUTES is for a directory.
See `file-attributes'."
;; Can also be a string for symlinks, so check for t explicitly.
(eq (file-attribute-type attributes) t))
(defsubst dired-async--same-device-p (f1 f2)
"Return non-nil if F1 and F2 have the same device number."
;; file-attribute-device-number may be a cons cell, so use equal for
;; testing (See Emacs bug/58446).
(equal (file-attribute-device-number (file-attributes f1))
(file-attribute-device-number (file-attributes f2))))
(defun dired-async--small-file-p (file)
"Return non-nil if FILE is considered small.
File is considered small if it size is smaller than
`dired-async-small-file-max'."
(let ((a (file-attributes file)))
;; Directories are always large since we can't easily figure out
;; their total size.
(and (not (dired-async--directory-p a))
(< (file-attribute-size a) dired-async-small-file-max))))
(defun dired-async--skip-async-p (file-creator file name-constructor)
"Return non-nil if we should skip async for FILE.
See `dired-create-files' for FILE-CREATOR and NAME-CONSTRUCTOR."
;; Skip async for small files.
(or (dired-async--small-file-p file)
;; Also skip async for same device renames.
(and (eq file-creator 'dired-rename-file)
(let ((new (funcall name-constructor file)))
(dired-async--same-device-p file (file-name-directory new))))))
(defun dired-async--smart-create-files (old-func file-creator
operation fn-list name-constructor
&optional marker-char)
"Around advice for `dired-create-files'.
Uses async like `dired-async-create-files' but skips certain fast
cases if `dired-async-skip-fast' is non-nil."
(let (async-list quick-list)
(if (or (eq file-creator 'backup-file)
(null dired-async-skip-fast))
(setq async-list fn-list)
(dolist (old fn-list)
(if (dired-async--skip-async-p file-creator old name-constructor)
(push old quick-list)
(push old async-list))))
(when async-list
(dired-async-create-files
file-creator operation (nreverse async-list)
name-constructor marker-char))
(when quick-list
(funcall old-func file-creator operation
(nreverse quick-list) name-constructor marker-char))))
(defvar overwrite-query)
(defun dired-async-create-files (file-creator operation fn-list name-constructor
&optional _marker-char)
@@ -281,47 +347,49 @@ ESC or `q' to not overwrite any of the remaining files,
(set-visited-file-name to t t))))))))
;; Start async process.
(when async-fn-list
(async-start `(lambda ()
(require 'cl-lib) (require 'dired-aux) (require 'dired-x)
,(async-inject-variables dired-async-env-variables-regexp)
(let ((dired-recursive-copies (quote always))
(dired-copy-preserve-time
,dired-copy-preserve-time))
(setq overwrite-backup-query nil)
;; Inline `backup-file' as long as it is not
;; available in emacs.
(defalias 'backup-file
;; Same feature as "cp -f --backup=numbered from to"
;; Symlinks are copied as file from source unlike
;; `dired-copy-file' which is same as cp -d.
;; Directories are omitted.
(lambda (from to ok)
(cond ((file-directory-p from) (ignore))
(t (let ((count 0))
(while (let ((attrs (file-attributes to)))
(and attrs (null (nth 0 attrs))))
(cl-incf count)
(setq to (concat (file-name-sans-versions to)
(format ".~%s~" count)))))
(condition-case err
(copy-file from to ok dired-copy-preserve-time)
(file-date-error
(dired-log "Can't set date on %s:\n%s\n" from err)))))))
;; Now run the FILE-CREATOR function on files.
(cl-loop with fn = (quote ,file-creator)
for (from . dest) in (quote ,async-fn-list)
do (condition-case err
(funcall fn from dest t)
(file-error
(dired-log "%s: %s\n" (car err) (cdr err))
nil)))
(when (get-buffer dired-log-buffer)
(dired-log t)
(with-current-buffer dired-log-buffer
(write-region (point-min) (point-max)
,dired-async-log-file))))
,(dired-async-maybe-kill-ftp))
callback)
(process-put
(async-start `(lambda ()
(require 'cl-lib) (require 'dired-aux) (require 'dired-x)
,(async-inject-variables dired-async-env-variables-regexp)
(let ((dired-recursive-copies (quote always))
(dired-copy-preserve-time
,dired-copy-preserve-time))
(setq overwrite-backup-query nil)
;; Inline `backup-file' as long as it is not
;; available in emacs.
(defalias 'backup-file
;; Same feature as "cp -f --backup=numbered from to"
;; Symlinks are copied as file from source unlike
;; `dired-copy-file' which is same as cp -d.
;; Directories are omitted.
(lambda (from to ok)
(cond ((file-directory-p from) (ignore))
(t (let ((count 0))
(while (let ((attrs (file-attributes to)))
(and attrs (null (nth 0 attrs))))
(cl-incf count)
(setq to (concat (file-name-sans-versions to)
(format ".~%s~" count)))))
(condition-case err
(copy-file from to ok dired-copy-preserve-time)
(file-date-error
(dired-log "Can't set date on %s:\n%s\n" from err)))))))
;; Now run the FILE-CREATOR function on files.
(cl-loop with fn = (quote ,file-creator)
for (from . dest) in (quote ,async-fn-list)
do (condition-case err
(funcall fn from dest t)
(file-error
(dired-log "%s: %s\n" (car err) (cdr err))
nil)))
(when (get-buffer dired-log-buffer)
(dired-log t)
(with-current-buffer dired-log-buffer
(write-region (point-min) (point-max)
,dired-async-log-file))))
,(dired-async-maybe-kill-ftp))
callback)
'dired-async-process t)
;; Run mode-line notifications while process running.
(dired-async--modeline-mode 1)
(message "%s proceeding asynchronously..." operation))))
@@ -342,10 +410,10 @@ ESC or `q' to not overwrite any of the remaining files,
:global t
(if dired-async-mode
(progn
(advice-add 'dired-create-files :override #'dired-async-create-files)
(advice-add 'dired-create-files :around #'dired-async--smart-create-files)
(advice-add 'wdired-do-renames :around #'dired-async-wdired-do-renames))
(progn
(advice-remove 'dired-create-files #'dired-async-create-files)
(advice-remove 'dired-create-files #'dired-async--smart-create-files)
(advice-remove 'wdired-do-renames #'dired-async-wdired-do-renames))))
(defmacro dired-async--with-async-create-files (&rest body)

22
lisp/async/smtpmail-async.el
View File

@@ -1,6 +1,6 @@
;;; smtpmail-async.el --- Send e-mail with smtpmail.el asynchronously -*- lexical-binding: t -*-
;; Copyright (C) 2012-2016 Free Software Foundation, Inc.
;; Copyright (C) 2012-2022 Free Software Foundation, Inc.
;; Author: John Wiegley <jwiegley@gmail.com>
;; Created: 18 Jun 2012
@@ -8,20 +8,18 @@
;; Keywords: email async
;; X-URL: https://github.com/jwiegley/emacs-async
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2, or (at
;; your option) any later version.
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:

25
lisp/avy.el
View File

@@ -4,8 +4,8 @@
;; Author: Oleh Krehel <ohwoeowho@gmail.com>
;; URL: https://github.com/abo-abo/avy
;; Package-Version: 20220102.805
;; Package-Commit: ba5f035be33693d1a136a5cbeedb24327f551a92
;; Package-Version: 20220910.1936
;; Package-Commit: 955c8dedd68c74f3cf692c1249513f048518c4c9
;; Version: 0.5.0
;; Package-Requires: ((emacs "24.1") (cl-lib "0.5"))
;; Keywords: point, location
@@ -457,6 +457,9 @@ KEYS is the path from the root of `avy-tree' to LEAF."
(defvar avy-action nil
"Function to call at the end of select.")
(defvar avy-action-oneshot nil
"Function to call once at the end of select.")
(defun avy-handler-default (char)
"The default handler for a bad CHAR."
(let (dispatch)
@@ -892,10 +895,11 @@ multiple OVERLAY-FN invocations."
(t
(funcall avy-pre-action res)
(setq res (car res))
(funcall (or avy-action 'avy-action-goto)
(if (consp res)
(car res)
res))
(let ((action (or avy-action avy-action-oneshot 'avy-action-goto)))
(funcall action
(if (consp res)
(car res)
res)))
res))))
(define-obsolete-function-alias 'avy--process 'avy-process
@@ -1017,10 +1021,11 @@ COMPOSE-FN is a lambda that concatenates the old string at BEG with STR."
(os-line-prefix (get-text-property 0 'line-prefix old-str))
(os-wrap-prefix (get-text-property 0 'wrap-prefix old-str))
other-ol)
(when os-line-prefix
(add-text-properties 0 1 `(line-prefix ,os-line-prefix) str))
(when os-wrap-prefix
(add-text-properties 0 1 `(wrap-prefix ,os-wrap-prefix) str))
(unless (= (length str) 0)
(when os-line-prefix
(add-text-properties 0 1 `(line-prefix ,os-line-prefix) str))
(when os-wrap-prefix
(add-text-properties 0 1 `(wrap-prefix ,os-wrap-prefix) str)))
(when (setq other-ol (cl-find-if
(lambda (o) (overlay-get o 'goto-address))
(overlays-at beg)))

2
lisp/biblio/biblio-pkg.el
View File

@@ -1,7 +1,7 @@
(define-package "biblio" "20210418.406" "Browse and import bibliographic references from CrossRef, arXiv, DBLP, HAL, Dissemin, and doi.org"
'((emacs "24.3")
(biblio-core "0.2"))
:commit "517ec18f00f91b61481214b178f7ae0b8fbc499b" :authors
:commit "368f45bf9a64450705a63598224c5af96160af76" :authors
'(("Clément Pit-Claudel" . "clement.pitclaudel@live.com"))
:maintainer
'("Clément Pit-Claudel" . "clement.pitclaudel@live.com")

155
lisp/bibtex-completion.el
View File

@@ -4,8 +4,8 @@
;; Justin Burkett <justin@burkett.cc>
;; Maintainer: Titus von der Malsburg <malsburg@posteo.de>
;; URL: https://github.com/tmalsburg/helm-bibtex
;; Package-Version: 20211019.1306
;; Package-Commit: aa775340ba691d2322948bfdc6a88158568a1399
;; Package-Version: 20221024.857
;; Package-Commit: 78f5931e1cc82e7ae2bcf0508cf31d0d1629a8dd
;; Version: 1.0.0
;; Package-Requires: ((parsebib "1.0") (s "1.9.0") (dash "2.6.0") (f "0.16.2") (cl-lib "0.5") (biblio "0.2") (emacs "26.1"))
@@ -368,7 +368,6 @@ bibliography file is reparsed.")
(defvar bibtex-completion-string-hash-table nil
"A hash table used for string replacements.")
(defun bibtex-completion-normalize-bibliography (&optional type)
"Return a list of bibliography file(s) in `bibtex-completion-bibliography'.
If there are org mode bibliography-files, their corresponding
@@ -383,7 +382,18 @@ their associated bibtex files."
bib-file)
for bibtex-file = (if (consp bib-file)
(cdr bib-file)
(concat (file-name-sans-extension main-file) ".bib"))
(cond
((string= (file-name-extension main-file) "bib") main-file)
((string= (file-name-extension main-file) "org")
(concat (file-name-sans-extension main-file) "bib"))
((and (string= (file-name-extension main-file) "gpg")
(string= (file-name-extension
(file-name-sans-extension main-file)) "bib")) main-file)
((and (string= (file-name-extension main-file) "gpg")
(string= (file-name-extension
(file-name-sans-extension main-file)) "org"))
(concat (file-name-sans-extension
(file-name-sans-extension main-file)) ".bib.gpg"))))
unless (equal type 'bibtex)
collect main-file
unless (equal type 'main)
@@ -488,7 +498,7 @@ The first element of these conses is a string containing authors,
editors, title, year, type, and key of the entry. This string
is used for matching. The second element is the entry (only the
fields listed above) as an alist."
(let ((files (nreverse (bibtex-completion-normalize-bibliography 'bibtex)))
(let ((files (bibtex-completion-normalize-bibliography 'bibtex))
(ht-strings (make-hash-table :test #'equal))
reparsed-files)
@@ -569,10 +579,9 @@ fields listed above) as an alist."
;; Finally return the list of candidates:
(message "Done (re)loading bibliography.")
(nreverse
(cl-loop
for file in files
append (cddr (assoc file bibtex-completion-cache))))))
(cl-loop
for file in files
append (reverse (cddr (assoc file bibtex-completion-cache))))))
(defun bibtex-completion-resolve-crossrefs (files reparsed-files)
"Expand all entries with fields from cross-referenced entries in FILES, assuming that only those files in REPARSED-FILES were reparsed whereas the other files in FILES were up-to-date."
@@ -1155,66 +1164,64 @@ The format depends on
(defun bibtex-completion-apa-get-value (field entry &optional default)
"Return FIELD or ENTRY formatted following the APA guidelines.
Return DEFAULT if FIELD is not present in ENTRY."
;; Virtual fields:
(pcase field
("author-or-editor"
;; Avoid if-let and when-let because they're not working reliably
;; in all versions of Emacs that we currently support:
(let ((value (bibtex-completion-get-value "author" entry)))
(if value
(bibtex-completion-apa-format-authors value)
(bibtex-completion-apa-format-editors
(bibtex-completion-get-value "editor" entry)))))
("author-or-editor-abbrev"
(let* ((value (bibtex-completion-get-value "author" entry)))
(if value
(bibtex-completion-apa-format-authors-abbrev value)
(bibtex-completion-apa-format-editors-abbrev
(bibtex-completion-get-value "editor" entry)))))
("author-abbrev"
(let ((value (bibtex-completion-get-value "author" entry)))
(when value
(bibtex-completion-apa-format-authors-abbrev value))))
("editor-abbrev"
(let ((value (bibtex-completion-get-value "editor" entry)))
(when value
(bibtex-completion-apa-format-editors-abbrev value))))
(_
;; Real fields:
(let ((value (bibtex-completion-get-value field entry)))
(if value
(pcase field
;; https://owl.english.purdue.edu/owl/resource/560/06/
("author" (bibtex-completion-apa-format-authors value))
("editor" (bibtex-completion-apa-format-editors value))
;; When referring to books, chapters, articles, or Web pages,
;; capitalize only the first letter of the first word of a
;; title and subtitle, the first word after a colon or a dash
;; in the title, and proper nouns. Do not capitalize the first
;; letter of the second word in a hyphenated compound word.
("title" (replace-regexp-in-string ; remove braces
"[{}]"
""
(replace-regexp-in-string ; remove macros
"\\\\[[:alpha:]]+{"
Return DEFAULT if FIELD is not present in ENTRY. Return empty
string if FIELD is not present in ENTRY and DEFAULT is nil."
(or
(pcase field
;; Virtual fields:
("author-or-editor"
;; Avoid if-let and when-let because they're not working reliably
;; in all versions of Emacs that we currently support:
(if-let ((value (bibtex-completion-get-value "author" entry)))
(bibtex-completion-apa-format-authors value)
(when-let ((value (bibtex-completion-get-value "editor" entry)))
(bibtex-completion-apa-format-editors value))))
("author-or-editor-abbrev"
(if-let ((value (bibtex-completion-get-value "author" entry)))
(bibtex-completion-apa-format-authors-abbrev value)
(when-let ((value (bibtex-completion-get-value "editor" entry)))
(bibtex-completion-apa-format-editors-abbrev value))))
("author-abbrev"
(when-let ((value (bibtex-completion-get-value "author" entry)))
(bibtex-completion-apa-format-authors-abbrev value)))
("editor-abbrev"
(when-let ((value (bibtex-completion-get-value "editor" entry)))
(bibtex-completion-apa-format-editors-abbrev value)))
(_
;; Real fields:
(let ((value (bibtex-completion-get-value field entry)))
(if value
(pcase field
;; https://owl.english.purdue.edu/owl/resource/560/06/
("author" (bibtex-completion-apa-format-authors value))
("editor" (bibtex-completion-apa-format-editors value))
;; When referring to books, chapters, articles, or Web pages,
;; capitalize only the first letter of the first word of a
;; title and subtitle, the first word after a colon or a dash
;; in the title, and proper nouns. Do not capitalize the first
;; letter of the second word in a hyphenated compound word.
("title" (replace-regexp-in-string ; remove braces
"[{}]"
""
(replace-regexp-in-string ; upcase initial letter
"^[[:alpha:]]"
'upcase
(replace-regexp-in-string ; preserve stuff in braces from being downcased
"\\(^[^{]*{\\)\\|\\(}[^{]*{\\)\\|\\(}.*$\\)\\|\\(^[^{}]*$\\)"
(lambda (x) (downcase (s-replace "\\" "\\\\" x)))
value)))))
("booktitle" value)
;; Maintain the punctuation and capitalization that is used by
;; the journal in its title.
("pages" (s-join "–" (s-split "[^0-9]+" value t)))
("doi" (s-concat " http://dx.doi.org/" value))
("year" (or value
(car (split-string (bibtex-completion-get-value "date" entry "") "-"))))
(_ value))
(or default ""))))))
(replace-regexp-in-string ; remove macros
"\\\\[[:alpha:]]+{"
""
(replace-regexp-in-string ; upcase initial letter
"^[[:alpha:]]"
'upcase
(replace-regexp-in-string ; preserve stuff in braces from being downcased
"\\(^[^{]*{\\)\\|\\(}[^{]*{\\)\\|\\(}.*$\\)\\|\\(^[^{}]*$\\)"
(lambda (x) (downcase (s-replace "\\" "\\\\" x)))
value)))))
("booktitle" value)
;; Maintain the punctuation and capitalization that is used by
;; the journal in its title.
("pages" (s-join "–" (s-split "[^0-9]+" value t)))
("doi" (s-concat " http://dx.doi.org/" value))
("year" (or value
(car (split-string (bibtex-completion-get-value "date" entry "") "-"))))
(_ value))))))
default ""))
(defun bibtex-completion-apa-format-authors (value &optional abbrev)
"Format author list in VALUE in APA style.
@@ -1611,10 +1618,20 @@ find the key of the BibTeX entry at point in an Org-mode buffer."
(> (length key) 0)
key))))
(defun bibtex-completion-get-key-org-cite ()
"Return the org-cite key at point, nil otherwise.
This function can be used by `bibtex-completion-key-at-point' to
find the org-cite key at point in an Org-mode buffer."
(when (eq major-mode 'org-mode)
(let ((el (org-element-context)))
(when (eq (car el) 'citation-reference)
(plist-get (cadr el) :key)))))
(defvar bibtex-completion-key-at-point-functions
(list #'bibtex-completion-get-key-bibtex
#'bibtex-completion-get-key-latex
#'bibtex-completion-get-key-org-bibtex)
#'bibtex-completion-get-key-org-bibtex
#'bibtex-completion-get-key-org-cite)
"List of functions to use to find the BibTeX key.
The functions should take no argument and return the BibTeX
key. Stops as soon as a function returns something.

192
lisp/bind-key.el
View File

@@ -1,42 +1,40 @@
;;; bind-key.el --- A simple way to manage personal keybindings
;;; bind-key.el --- A simple way to manage personal keybindings -*- lexical-binding: t; -*-
;; Copyright (c) 2012-2017 John Wiegley
;; Copyright (c) 2012-2022 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@newartisans.com>
;; Maintainer: John Wiegley <johnw@newartisans.com>
;; Created: 16 Jun 2012
;; Modified: 29 Nov 2017
;; Version: 2.4
;; Package-Version: 20210210.1609
;; Package-Commit: a7422fb8ab1baee19adb2717b5b47b9c3812a84c
;; Keywords: keys keybinding config dotemacs
;; Version: 2.4.1
;; Package-Version: 20221209.2013
;; Package-Commit: bcf0984cf55b70fe6896c6a15f61df92b24f8ffd
;; Package-Requires: ((emacs "24.3"))
;; Keywords: keys keybinding config dotemacs extensions
;; URL: https://github.com/jwiegley/use-package
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the gnu general public license as
;; published by the free software foundation; either version 3, or (at
;; your option) any later version.
;; This file is part of GNU Emacs.
;; This program is distributed in the hope that it will be useful, but
;; without any warranty; without even the implied warranty of
;; merchantability or fitness for a particular purpose. see the gnu
;; general public license for more details.
;; GNU Emacs is free software: you can redistribute 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/>.
;; You should have received a copy of the gnu general public license
;; along with gnu emacs; see the file copying. if not, write to the
;; free software foundation, inc., 59 temple place - suite 330,
;; boston, ma 02111-1307, usa.
;;; Commentary:
;; If you have lots of keybindings set in your .emacs file, it can be hard to
;; know which ones you haven't set yet, and which may now be overriding some
;; new default in a new emacs version. This module aims to solve that
;; problem.
;; If you have lots of keybindings set in your init file, it can be
;; hard to know which ones you haven't set yet, and which may now be
;; overriding some new default in a new Emacs version. This module
;; aims to solve that problem.
;;
;; Bind keys as follows in your .emacs:
;;
;; (require 'bind-key)
;; Bind keys as follows in your init file:
;;
;; (bind-key "C-c x" 'my-ctrl-c-x-command)
;;
@@ -99,6 +97,8 @@
;; This display will tell you if you've overridden a default keybinding, and
;; what the default was. Also, it will tell you if the key was rebound after
;; your binding it with `bind-key', and what it was rebound it to.
;;
;; See the `use-package' info manual for more information.
;;; Code:
@@ -106,8 +106,11 @@
(require 'easy-mmode)
(defgroup bind-key nil
"A simple way to manage personal keybindings"
:group 'emacs)
"A simple way to manage personal keybindings."
:group 'keyboard
:group 'convenience
:link '(emacs-commentary-link :tag "Commentary" "bind-key.el")
:version "29.1")
(defcustom bind-key-column-widths '(18 . 40)
"Width of columns in `describe-personal-keybindings'."
@@ -116,8 +119,7 @@
(defcustom bind-key-segregation-regexp
"\\`\\(\\(C-[chx] \\|M-[gso] \\)\\([CM]-\\)?\\|.+-\\)"
"Regular expression used to divide key sets in the output from
\\[describe-personal-keybindings]."
"Regexp used by \\[describe-personal-keybindings] to divide key sets."
:type 'regexp
:group 'bind-key)
@@ -129,11 +131,23 @@
;; Create override-global-mode to force key remappings
(defvar override-global-map (make-keymap)
"override-global-mode keymap")
"Keymap for `override-global-mode'.")
(define-minor-mode override-global-mode
"A minor mode so that keymap settings override other modes."
t "")
"A minor mode for allowing keybindings to override other modes.
The main purpose of this mode is to simplify bindings keys in
such a way that they take precedence over other modes.
To achieve this, the keymap `override-global-map' is added to
`emulation-mode-map-alists', which makes it take precedence over
keymaps in `minor-mode-map-alist'. Thereby, key bindings get an
even higher precedence than global key bindings defined with
`keymap-global-set' (or, in Emacs 28 or older, `global-set-key').
The macro `bind-key*' (which see) provides a convenient way to
add keys to that keymap."
:init-value t
:lighter "")
;; the keymaps in `emulation-mode-map-alists' take precedence over
;; `minor-mode-map-alist'
@@ -150,18 +164,18 @@ Elements have the form ((KEY . [MAP]) CMD ORIGINAL-CMD)")
"Bind KEY-NAME to COMMAND in KEYMAP (`global-map' if not passed).
KEY-NAME may be a vector, in which case it is passed straight to
`define-key'. Or it may be a string to be interpreted as
spelled-out keystrokes, e.g., \"C-c C-z\". See documentation of
`edmacro-mode' for details.
`define-key'. Or it may be a string to be interpreted as
spelled-out keystrokes, e.g., \"C-c C-z\". See the documentation
of `edmacro-mode' for details.
COMMAND must be an interactive function or lambda form.
KEYMAP, if present, should be a keymap variable or symbol.
For example:
(bind-key \"M-h\" #'some-interactive-function my-mode-map)
(bind-key \"M-h\" #\\='some-interactive-function my-mode-map)
(bind-key \"M-h\" #'some-interactive-function 'my-mode-map)
(bind-key \"M-h\" #\\='some-interactive-function \\='my-mode-map)
If PREDICATE is non-nil, it is a form evaluated to determine when
a key should be bound. It must return non-nil in such cases.
@@ -174,8 +188,9 @@ can safely be called at any time."
(kdescvar (make-symbol "kdesc"))
(bindingvar (make-symbol "binding")))
`(let* ((,namevar ,key-name)
(,keyvar (if (vectorp ,namevar) ,namevar
(read-kbd-macro ,namevar)))
(,keyvar ,(if (stringp key-name) (read-kbd-macro key-name)
`(if (vectorp ,namevar) ,namevar
(read-kbd-macro ,namevar))))
(,kmapvar (or (if (and ,keymap (symbolp ,keymap))
(symbol-value ,keymap) ,keymap)
global-map))
@@ -223,11 +238,11 @@ See `bind-key' for more details."
In contrast to `define-key', this function removes the binding from the keymap."
(define-key keymap key nil)
;; Split M-key in ESC key
(setq key (mapcan (lambda (k)
(if (and (integerp k) (/= (logand k ?\M-\0) 0))
(list ?\e (logxor k ?\M-\0))
(list k)))
key))
(setq key (cl-mapcan (lambda (k)
(if (and (integerp k) (/= (logand k ?\M-\0) 0))
(list ?\e (logxor k ?\M-\0))
(list k)))
key))
;; Delete single keys directly
(if (= (length key) 1)
(delete key keymap)
@@ -241,7 +256,7 @@ In contrast to `define-key', this function removes the binding from the keymap."
(delete (last key) submap)
;; Delete submap if it is empty
(when (= 1 (length submap))
(bind-key--remove prefix keymap)))))
(bind-key--remove prefix keymap)))))
;;;###autoload
(defmacro bind-key* (key-name command &optional predicate)
@@ -259,30 +274,60 @@ Accepts keyword arguments:
for these bindings
:prefix-docstring STR - docstring for the prefix-map variable
:menu-name NAME - optional menu string for prefix map
:repeat-docstring STR - docstring for the repeat-map variable
:repeat-map MAP - name of the repeat map that should be created
for these bindings. If specified, the
`repeat-map' property of each command bound
(within the scope of the `:repeat-map' keyword)
is set to this map.
:exit BINDINGS - Within the scope of `:repeat-map' will bind the
key in the repeat map, but will not set the
`repeat-map' property of the bound command.
:continue BINDINGS - Within the scope of `:repeat-map' forces the
same behaviour as if no special keyword had
been used (that is, the command is bound, and
it's `repeat-map' property set)
:filter FORM - optional form to determine when bindings apply
The rest of the arguments are conses of keybinding string and a
function symbol (unquoted)."
(let (map
doc
prefix-doc
prefix-map
prefix
repeat-map
repeat-doc
repeat-type ;; Only used internally
filter
menu-name
pkg)
;; Process any initial keyword arguments
(let ((cont t))
(let ((cont t)
(arg-change-func 'cddr))
(while (and cont args)
(if (cond ((and (eq :map (car args))
(not prefix-map))
(setq map (cadr args)))
((eq :prefix-docstring (car args))
(setq doc (cadr args)))
(setq prefix-doc (cadr args)))
((and (eq :prefix-map (car args))
(not (memq map '(global-map
override-global-map))))
(setq prefix-map (cadr args)))
((eq :repeat-docstring (car args))
(setq repeat-doc (cadr args)))
((and (eq :repeat-map (car args))
(not (memq map '(global-map
override-global-map))))
(setq repeat-map (cadr args))
(setq map repeat-map))
((eq :continue (car args))
(setq repeat-type :continue
arg-change-func 'cdr))
((eq :exit (car args))
(setq repeat-type :exit
arg-change-func 'cdr))
((eq :prefix (car args))
(setq prefix (cadr args)))
((eq :filter (car args))
@@ -291,13 +336,17 @@ function symbol (unquoted)."
(setq menu-name (cadr args)))
((eq :package (car args))
(setq pkg (cadr args))))
(setq args (cddr args))
(setq args (funcall arg-change-func args))
(setq cont nil))))
(when (or (and prefix-map (not prefix))
(and prefix (not prefix-map)))
(error "Both :prefix-map and :prefix must be supplied"))
(when repeat-type
(unless repeat-map
(error ":continue and :exit require specifying :repeat-map")))
(when (and menu-name (not prefix))
(error "If :menu-name is supplied, :prefix must be too"))
@@ -329,13 +378,16 @@ function symbol (unquoted)."
(append
(when prefix-map
`((defvar ,prefix-map)
,@(when doc `((put ',prefix-map 'variable-documentation ,doc)))
,@(when prefix-doc `((put ',prefix-map 'variable-documentation ,prefix-doc)))
,@(if menu-name
`((define-prefix-command ',prefix-map nil ,menu-name))
`((define-prefix-command ',prefix-map)))
,@(if (and map (not (eq map 'global-map)))
(wrap map `((bind-key ,prefix ',prefix-map ,map ,filter)))
`((bind-key ,prefix ',prefix-map nil ,filter)))))
(when repeat-map
`((defvar ,repeat-map (make-sparse-keymap)
,@(when repeat-doc `(,repeat-doc)))))
(wrap map
(cl-mapcan
(lambda (form)
@@ -343,13 +395,19 @@ function symbol (unquoted)."
(if prefix-map
`((bind-key ,(car form) ,fun ,prefix-map ,filter))
(if (and map (not (eq map 'global-map)))
`((bind-key ,(car form) ,fun ,map ,filter))
;; Only needed in this branch, since when
;; repeat-map is non-nil, map is always
;; non-nil
`(,@(when (and repeat-map (not (eq repeat-type :exit)))
`((put ,fun 'repeat-map ',repeat-map)))
(bind-key ,(car form) ,fun ,map ,filter))
`((bind-key ,(car form) ,fun nil ,filter))))))
first))
(when next
(bind-keys-form (if pkg
(cons :package (cons pkg next))
next) map)))))))
(bind-keys-form `(,@(when repeat-map `(:repeat-map ,repeat-map))
,@(if pkg
(cons :package (cons pkg next))
next)) map)))))))
;;;###autoload
(defmacro bind-keys (&rest args)
@@ -363,6 +421,19 @@ Accepts keyword arguments:
for these bindings
:prefix-docstring STR - docstring for the prefix-map variable
:menu-name NAME - optional menu string for prefix map
:repeat-docstring STR - docstring for the repeat-map variable
:repeat-map MAP - name of the repeat map that should be created
for these bindings. If specified, the
`repeat-map' property of each command bound
(within the scope of the `:repeat-map' keyword)
is set to this map.
:exit BINDINGS - Within the scope of `:repeat-map' will bind the
key in the repeat map, but will not set the
`repeat-map' property of the bound command.
:continue BINDINGS - Within the scope of `:repeat-map' forces the
same behaviour as if no special keyword had
been used (that is, the command is bound, and
it's `repeat-map' property set)
:filter FORM - optional form to determine when bindings apply
The rest of the arguments are conses of keybinding string and a
@@ -371,6 +442,11 @@ function symbol (unquoted)."
;;;###autoload
(defmacro bind-keys* (&rest args)
"Bind multiple keys at once, in `override-global-map'.
Accepts the same keyword arguments as `bind-keys' (which see).
This binds keys in such a way that bindings are not overridden by
other modes. See `override-global-mode'."
(macroexp-progn (bind-keys-form args 'override-global-map)))
(defun get-binding-description (elem)
@@ -463,8 +539,7 @@ function symbol (unquoted)."
(command-desc (get-binding-description command))
(was-command-desc (and was-command
(get-binding-description was-command)))
(at-present-desc (get-binding-description at-present))
)
(at-present-desc (get-binding-description at-present)))
(let ((line
(format
(format "%%-%ds%%-%ds%%s\n" (car bind-key-column-widths)
@@ -486,7 +561,6 @@ function symbol (unquoted)."
;; Local Variables:
;; outline-regexp: ";;;\\(;* [^\s\t\n]\\|###autoload\\)\\|("
;; indent-tabs-mode: nil
;; End:
;;; bind-key.el ends here

181
lisp/cfrs.el Normal file
View File

@@ -0,0 +1,181 @@
;;; cfrs.el --- Child-frame based read-string -*- lexical-binding: t -*-
;; Copyright (C) 2021 Alexander Miller
;; Author: Alexander Miller <alexanderm@web.de>
;; Package-Requires: ((emacs "26.1") (dash "2.11.0") (s "1.10.0") (posframe "0.6.0"))
;; Package-Commit: f3a21f237b2a54e6b9f8a420a9da42b4f0a63121
;; Package-Version: 20220129.1149
;; Package-X-Original-Version: 1.6.0
;; Homepage: https://github.com/Alexander-Miller/cfrs
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Simple implementation of reading a string with child-frames.
;;; Synchronous control is maintained by using `recursive-edit'. When finished
;;; the entered text is read from the input buffer and the child-frame is
;;; hidden.
;;; Code:
(require 's)
(require 'dash)
(require 'posframe)
(defgroup cfrs nil
"Cfrs configuration options."
:group 'cfrs
:prefix "cfrs-")
(defcustom cfrs-frame-parameters nil
"Alist of parameters for cfrs' child frames.
Can be used to override useful parameters like `internal-border-width' or
`background-color' for better frame visibility."
:type '(alist :key-type symbol)
:group 'cfrs)
(defcustom cfrs-max-width 80
"The maximum width of the cfrs input field.
cfrs will try to extend its initial width to fit both the prompt and the initial
input, up to a maximum of `cfrs-max-width' characters. For any combination
longer than this horizontal scrolling will be necessary.
See also `cfrs-min-width'"
:type 'integer
:group 'cfrs)
(defcustom cfrs-min-width 40
"The minimum width of the cfrs input field.
cfrs will never be smaller than `cfrs-min-width' characters regardless of the
length of the prompt and initial input.
See also `cfrs-max-width'"
:type 'integer
:group 'cfrs)
(defface cfrs-border-color
`((t :inherit internal-border))
"The face for the border of the cfrs popup frame.
Only the `:background' part is used."
:group 'cfrs)
;;;###autoload
(defun cfrs-read (prompt &optional initial-input)
"Read a string using a pos-frame with given PROMPT and INITIAL-INPUT."
(if (not (or (display-graphic-p)
(not (fboundp #'display-buffer-in-side-window))))
(read-string prompt initial-input)
(let* ((buffer (get-buffer-create " *Pos-Frame-Read*"))
(border-color (face-attribute 'cfrs-border-color :background nil t))
(cursor (cfrs--determine-cursor-type))
(width (+ 2 ;; extra space for margin and cursor
(min cfrs-max-width
(max cfrs-min-width
(+ (length prompt)
(if initial-input (length initial-input) 0))))))
(frame (posframe-show
buffer
:min-height 1
:min-width width
:internal-border-width 2
:internal-border-color border-color
:string ""
:accept-focus t
:override-parameters `(,@cfrs-frame-parameters
(cursor-type . ,cursor)))))
(with-selected-frame frame
(select-frame frame)
(x-focus-frame frame)
(add-hook 'delete-frame-functions #'cfrs--on-frame-kill nil :local)
(with-current-buffer buffer
(cfrs-input-mode)
(-each (overlays-in (point-min) (point-max)) #'delete-overlay)
(erase-buffer)
(-doto (make-overlay 1 2)
(overlay-put
'before-string
(propertize (concat " " prompt) 'face 'minibuffer-prompt))
(overlay-put 'rear-nonsticky t)
(overlay-put 'read-only t))
(when initial-input
(insert initial-input))
(when (and (bound-and-true-p evil-mode)
(fboundp 'evil-insert-state))
(evil-insert-state nil))
(end-of-line)
(recursive-edit)
(cfrs--hide)
(s-trim (buffer-string)))))))
(defun cfrs--determine-cursor-type ()
"Determine the cursor type for the popup frame.
Prevents showing an invisible cursor with a height or width of 0."
(let ((ct (if (memq cursor-type '(t nil))
(frame-parameter (selected-frame) 'cursor-type)
cursor-type)))
(pcase ct
(`(,_ . 0) ct)
(`nil 'hbar)
(_ ct))))
(defun cfrs--hide ()
"Hide the current cfrs frame."
(when (eq major-mode 'cfrs-input-mode)
(posframe-hide (current-buffer))
(x-focus-frame (frame-parent (selected-frame)))))
(defun cfrs--adjust-height ()
"Adjust input frame's height to the number of lines in the buffer."
(set-frame-height (selected-frame) (count-lines (point-min) (point-max))))
(defun cfrs--on-frame-kill (frame)
"Redirect focus after FRAME is killed."
(-let [parent (or (frame-parent frame) (selected-frame))]
(x-focus-frame parent)))
(defun cfrs-finish ()
"Finish the cfrs read, returning the entered string."
(interactive)
;; XXX: workaround for persp believing we are in a different frame
;; and need a new perspective when the recursive edit ends
(set-frame-parameter (selected-frame) 'persp--recursive nil)
(exit-recursive-edit))
(defun cfrs-cancel ()
"Cancel the `cfrs-read' call and the function that called it."
(interactive)
(cfrs--hide)
(abort-recursive-edit))
(defvar cfrs-input-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "C-c C-c") #'cfrs-finish)
(define-key map [return] #'cfrs-finish)
(define-key map [remap keyboard-quit] #'cfrs-cancel)
map))
(define-derived-mode cfrs-input-mode fundamental-mode "Child Frame Read String"
"Simple mode for buffers displayed in cfrs's input frames."
(add-hook 'post-command-hook #'cfrs--adjust-height nil :local)
(display-line-numbers-mode -1))
;; https://github.com/Alexander-Miller/treemacs/issues/775
(with-eval-after-load 'beacon
(with-no-warnings
(add-to-list 'beacon-dont-blink-major-modes 'cfrs-input-mode)))
(provide 'cfrs)
;;; cfrs.el ends here

38
lisp/citeproc/citeproc-biblatex.el
View File

@@ -84,7 +84,7 @@
"Alist mapping biblatex item types to CSL item types.")
(defun citeproc-blt--to-csl-type (type entrysubtype)
"Return the csltype corresponding to blt TYPE and ENTRYSUBTYPE."
"Return the CSL type corresponding to blt TYPE and ENTRYSUBTYPE."
(pcase type
((or 'article 'periodical 'supperiodical)
(pcase entrysubtype
@@ -159,7 +159,7 @@
(version . version)
(volumes . number-of-volumes)
(pagetotal . number-of-pages)
(chapter-number . chapter)
(chapter . chapter-number)
(pages . page)
;; publisher
(origpublisher . original-publisher)
@@ -195,24 +195,22 @@ Only those fields are mapped that do not require further processing.")
Only those fields are mapped that do not require further
processing.")
(defun citeproc-blt--parse-date (d)
"Parse single biblatex date-time expression D."
;; Remove time part, if present.
(-when-let (time-sep-pos (cl-position ?T d))
(setq d (substring d 0 time-sep-pos)))
(--map (let ((converted (string-to-number it)))
(if (not (= converted 0))
converted
(error "Couldn't parse '%s' as a date" d)))
(split-string d "-")))
(defun citeproc-blt--to-csl-date (d)
"Return a CSL version of the biblatex date field given by D."
(let* ((interval-strings (split-string d "/"))
(interval-date-parts
(mapcar (lambda (x)
(let* ((parsed (parse-time-string x))
;; TODO: use more elegant accessors for the parsed
;; time while keeping Emacs 26 compatibility.
(year (elt parsed 5))
(month (elt parsed 4))
(day (elt parsed 3))
date)
(when year
(when day (push day date))
(when month (push month date))
(push year date)
date)))
interval-strings)))
(mapcar #'citeproc-blt--parse-date interval-strings)))
(list (cons 'date-parts interval-date-parts))))
(defun citeproc-blt--get-standard (v b &optional with-nocase)
@@ -237,8 +235,7 @@ V is undefined in B."
"Return the CSL-normalized value of a title string S.
If optional WITH-NOCASE is non-nil then convert BibTeX no-case
brackets to the corresponding CSL XML spans, and if optional
SENT-CASE is non-nil the convert to sentence-case. Return nil if
V is undefined in B."
SENT-CASE is non-nil the convert to sentence-case."
(if sent-case
(citeproc-s-sentence-case-title (citeproc-bt--to-csl s t) (not with-nocase))
(citeproc-bt--to-csl s with-nocase)))
@@ -348,7 +345,10 @@ biblatex variables in B."
(push (cons 'genre (or (assoc-default ~reftype citeproc-blt-reftype-to-genre)
(citeproc-bt--to-csl ~reftype)))
result))
;; We store the original bib(la)tex type for filtering purposes.
(push (cons 'blt-type (symbol-name ~type)) result)
;; names
;; TODO: handle editorb and editorc as well...
(when-let ((~editortype (alist-get 'editortype b))
(~editor (alist-get 'editor b))
(csl-var (assoc-default ~editortype
@@ -361,7 +361,7 @@ biblatex variables in B."
citeproc-blt-editortype-to-csl-name-alist)))
(push (cons csl-var (citeproc-bt--to-csl-names ~editora))
result))
;; TODO: do this for editorb and editorc as well... dates
;; dates
(-when-let (issued (-if-let (~issued (alist-get 'date b))
(citeproc-blt--to-csl-date ~issued)
(-when-let (~year (alist-get 'year b))

26
lisp/citeproc/citeproc-bibtex.el
View File

@@ -293,7 +293,7 @@ brackets to the corresponding CSL XML spans."
;; Brackets indicate corporate entities without name parts.
((and (string= "{" (substring trimmed 0 1))
(string= "}" (substring trimmed -1)))
`((family . ,(citeproc-bt--to-csl (substring trimmed 1 -1)))))
`((literal . ,(citeproc-bt--to-csl (substring trimmed 1 -1)))))
;; Else standard bib(la)tex name field processing.
(t (citeproc-bt--to-csl-name (citeproc-bt--to-csl trimmed))))))
name-fields)))
@@ -386,15 +386,21 @@ is not on this list are classified as non-dropping.")
"Return a CSL version of the date given by YEAR and MONTH.
YEAR and MONTH are the values of the corresponding BibTeX fields,
MONTH might be nil."
(let ((csl-year (string-to-number (car (s-match "[[:digit:]]+" year))))
(csl-month (when month
(assoc-default (downcase month)
citeproc-bt--mon-to-num-alist)))
date)
(when csl-year
(when csl-month (push csl-month date))
(push csl-year date))
(list (cons 'date-parts (list date)))))
(condition-case nil
(let ((csl-year (string-to-number (car (s-match "[[:digit:]]+" year))))
(csl-month (when month
(assoc-default (downcase month)
citeproc-bt--mon-to-num-alist)))
date)
(when csl-year
(when csl-month (push csl-month date))
(push csl-year date))
(list (cons 'date-parts (list date))))
(error
(error (concat "Couldn't parse year: '%s'"
(when month " and month: '%s'")
" as a date")
year month))))
(defun citeproc-bt-entry-to-csl (b)
"Return a CSL form of normalized parsed BibTeX entry B."

95
lisp/citeproc/citeproc-cite.el
View File

@@ -48,7 +48,7 @@ NOTE-INDEX is the note index of the citation if it occurs in a
note,
MODE is either nil (for the default citation mode) or one
of the symbols `suppress-author', `textual', `author-only',
`year-only',
`year-only', `title-only', `bib-entry', `locator-only',
SUPPRESS-AFFIXES is non-nil if the citation affixes should be
suppressed,
CAPITALIZE-FIRST is non-nil if the first word of the rendered
@@ -61,13 +61,22 @@ GROUPED is used internally to indicate whether the cites were
ignore-et-al grouped)
(defconst citeproc-cite--from-mode-alist
'((textual . (suppress-author . t))
(suppress-author . (suppress-author . t))
(author-only . (stop-rendering-at . names))
(year-only . (stop-rendering-at . issued)))
'((textual . ((suppress-author . t)))
(suppress-author . ((suppress-author . t)))
(author-only . ((stop-rendering-at . names)))
(year-only . ((stop-rendering-at . issued)))
(title-only . ((stop-rendering-at . title) (bib-entry . t) (use-short-title . t)))
(bib-entry . ((bib-entry . t)))
(locator-only . ((locator-only . t))))
"Alist mapping citation modes to corresponding cite-level
key-value pair representations.")
(defvar citeproc-citation-postprocess-functions nil
"A list of functions to postprocess rendered citations.
Each function takes a single argument, a rich-text, and returns a
post-processed rich-text value. The functions are applied in the
order they appear in the list.")
(defun citeproc-cite--varlist (cite)
"Return the varlist belonging to CITE."
(let* ((itd (alist-get 'itd cite))
@@ -77,7 +86,8 @@ key-value pair representations.")
(--filter (memq (car it)
'(label locator suppress-author suppress-date
stop-rendering-at position near-note
first-reference-note-number ignore-et-al))
first-reference-note-number ignore-et-al
bib-entry locator-only use-short-title))
cite)))
(nconc cite-vv item-vv)))
@@ -93,25 +103,52 @@ links else). For legacy reasons, any other value is treated as
`no-links'."
(-let* ((result nil)
((&alist 'suffix suff
'prefix pref)
'prefix pref
'bib-entry bib-entry
'locator-only locator-only
'stop-rendering-at stop-rendering-at)
cite)
(rt-pref (citeproc-rt-from-str pref))
(plain-pref (citeproc-rt-to-plain rt-pref))
(rt-suff (citeproc-rt-from-str suff))
(plain-suff (citeproc-rt-to-plain rt-suff))
(rendered-varlist
(citeproc-render-varlist-in-rt (citeproc-cite--varlist cite)
style 'cite 'display internal-links)))
(when (s-present-p plain-suff)
(push (citeproc-rt-from-str suff) result)
(unless (= (aref plain-suff 0) ?\s)
(push " " result)))
(push rendered-varlist result)
(when (s-present-p plain-pref)
(unless (= (aref plain-pref (1- (length plain-pref))) ?\s)
(push " " result))
(push rt-pref result))
(citeproc-rt-join-formatted nil result nil)))
(mode (if bib-entry 'bib 'cite))
(varlist (citeproc-cite--varlist cite)))
;; Remove cite-number when cite is the full bibliography entry.
(when (and (eq mode 'bib) (not stop-rendering-at))
(push '(citation-number) varlist))
(let ((rendered-varlist
(citeproc-render-varlist-in-rt
varlist style mode 'display
;; No link-targets for bib-entry based citations.
(if (eq mode 'bib) 'no-links internal-links)
;; No external limking for title-only citations, since we link to the
;; corresponding bibliography entry.
(eq stop-rendering-at 'title))))
;; Locator-only cites require extensive post-processing of full cite.
(when locator-only
(setq rendered-varlist (citeproc-rt-locator-w-label rendered-varlist)))
;; Title-only cites
(when (eq stop-rendering-at 'title)
(when-let* ((cite-no-attr
(citeproc-context-int-link-attrval
style internal-links 'cite (alist-get 'position varlist)))
(cite-no-attr-val (cons cite-no-attr
(alist-get 'citation-number varlist))))
;; Add cited-item-no attr to link to the bibliography entry
(setf (car rendered-varlist)
(-snoc (car rendered-varlist) cite-no-attr-val))))
;; Add cite prefix and suffix
(when (s-present-p plain-suff)
(push (citeproc-rt-from-str suff) result)
(unless (= (aref plain-suff 0) ?\s)
(push " " result)))
(push rendered-varlist result)
(when (s-present-p plain-pref)
(unless (= (aref plain-pref (1- (length plain-pref))) ?\s)
(push " " result))
(push rt-pref result))
(citeproc-rt-join-formatted nil result nil))))
(defun citeproc-cite-or-citegroup--render (c style internal-links top-dl gr-dl ys-dl ac-dl)
"Render cite or cite-group C with STYLE.
@@ -193,8 +230,9 @@ For the optional INTERNAL-LINKS argument see
;; Prepend author to textual citations
(when (eq (citeproc-citation-mode c) 'textual)
(let* ((first-elt (car cites)) ;; First elt is either a cite or a cite group.
;; If the latter then we need to locate the first cite as the
;; 2nd element of the first cite group.
;; If the latter then we need to locate the
;; first cite as the 2nd element of the first
;; cite group.
(first-cite (if (eq 'group (car first-elt))
(cadr first-elt)
first-elt))
@@ -206,9 +244,12 @@ For the optional INTERNAL-LINKS argument see
(alist-get 'stopped-rendering (car rendered-author)))
(setq result `(nil ,rendered-author " " ,result)))))
;; Capitalize first
(if (citeproc-citation-capitalize-first c)
(citeproc-rt-change-case result #'citeproc-s-capitalize-first)
result)))))
(when (citeproc-citation-capitalize-first c)
(setq result (citeproc-rt-change-case result #'citeproc-s-capitalize-first)))
;; Run the citation postprocessing hook
(dolist (fn citeproc-citation-postprocess-functions)
(setq result (funcall fn result)))
result))))
(defun citeproc-cites--collapse-indexed (cites index-getter no-span-pred)
"Collapse continuously indexed cites in CITES.
@@ -317,7 +358,7 @@ For the optional INTERNAL-LINKS argument see
(ignore-et-al (citeproc-citation-ignore-et-al citation)))
(-when-let (mode-rep
(alist-get mode citeproc-cite--from-mode-alist))
(push mode-rep (car cites)))
(setf (car cites) (nconc (car cites) mode-rep)))
(when ignore-et-al
(push '(ignore-et-al . t) (car cites))))))
@@ -441,7 +482,7 @@ INDEX is the actual note-index, NND is the near-note-distance."
(defvar citeproc-disambiguation-cite-pos 'last
"Which cite position should be the basis of cite disambiguation.
Possible values are 'last, 'first and 'subsequent.")
Possible values are `last', `first' and `subsequent'.")
(defun citeproc-proc-update-positions (proc)
"Update all position-related fields in PROC."

88
lisp/citeproc/citeproc-context.el
View File

@@ -67,23 +67,27 @@ MODE is either `bib' or `cite', RENDER-MODE is `display' or `sort'."
(defun citeproc-var-value (var context &optional form)
"Return the value of csl variable VAR in CONTEXT.
VAR is a symbol, CONTEXT is a `citeproc-context' struct, and the
optional FORM can be nil, 'short or 'long."
(if (eq form 'short)
(-if-let* ((short-var (alist-get var citeproc--short-long-var-alist))
(short-var-val (alist-get short-var (citeproc-context-vars context))))
short-var-val
(alist-get var (citeproc-context-vars context)))
(let ((var-val (alist-get var (citeproc-context-vars context))))
(if (and var-val (or (and (eq var 'locator)
(string= (citeproc-var-value 'label context) "page"))
(eq var 'page)))
(let ((prange-format (citeproc-lib-intern (alist-get 'page-range-format
(citeproc-context-opts context))))
(sep (or (citeproc-term-text-from-terms "page-range-delimiter"
(citeproc-context-terms context))
"–")))
(citeproc-prange-render var-val prange-format sep))
var-val))))
optional FORM can be nil, `short' or `long'."
(let ((var-vals (citeproc-context-vars context)))
(if (or (eq form 'short)
;; Also use the short form of title when the cite contains the
;; (use-short-title . t) pair. This is used for title-only citations.
(and (eq var 'title) (alist-get 'use-short-title var-vals)))
(-if-let* ((short-var (alist-get var citeproc--short-long-var-alist))
(short-var-val (alist-get short-var var-vals)))
short-var-val
(alist-get var var-vals))
(let ((var-val (alist-get var var-vals)))
(if (and var-val (or (and (eq var 'locator)
(string= (citeproc-var-value 'label context) "page"))
(eq var 'page)))
(let ((prange-format (citeproc-lib-intern (alist-get 'page-range-format
(citeproc-context-opts context))))
(sep (or (citeproc-term-text-from-terms "page-range-delimiter"
(citeproc-context-terms context))
"–")))
(citeproc-rt-from-str (citeproc-prange-render var-val prange-format sep)))
var-val)))))
(defun citeproc-locator-label (context)
"Return the current locator label variable from CONTEXT."
@@ -103,8 +107,8 @@ optional FORM can be nil, 'short or 'long."
(defun citeproc-rt-textcased (rts case context)
"Return rich-text content RTS in text-case CASE using CONTEXT.
CASE is one of the following: 'lowercase, 'uppercase,
'capitalize-first, 'capitalize-all, 'sentence, 'title."
CASE is one of the following: `lowercase', `uppercase',
`capitalize-first', `capitalize-all', `sentence', `title'."
(pcase case
('uppercase
(citeproc-rt-map-strings #'upcase rts t))
@@ -203,6 +207,23 @@ TYPED RTS is a list of (RICH-TEXT . TYPE) pairs"
(citeproc-term-gender match)
nil))
(defun citeproc-context-int-link-attrval (style internal-links mode cite-pos)
"Return an appropriate attribute to represent internal linking info.
INTERNAL-LINKS is the internal linking mode, see the
documentation of `citeproc-render-varlist-in-rt', while MODE is
the rendering mode, `bib' or `cite', and CITE-POS is a cite
position. Returns an appropriate attribute to be added or nil if
no internal links should be produced."
(let ((note-style (citeproc-style-cite-note style)))
(unless (or (and internal-links (not (memq internal-links '(auto bib-links))))
(and note-style (eq mode 'bib) (or (null internal-links)
(eq internal-links 'auto))))
(if (and note-style (not (eq internal-links 'bib-links)))
;; For note styles link subsequent cites to the first ones.
(if (eq cite-pos 'first) 'bib-item-no 'cited-item-no)
;; Else link each cite to the corresponding bib item.
(if (eq mode 'cite) 'cited-item-no 'bib-item-no)))))
(defun citeproc-render-varlist-in-rt (var-alist style mode render-mode &optional
internal-links no-external-links)
"Render an item described by VAR-ALIST with STYLE in rich-text.
@@ -237,25 +258,16 @@ external links."
(concat (alist-get var citeproc--link-prefix-alist
"")
(alist-get var var-alist))))))
;; Add appropriate item-no information
(let ((note-style (citeproc-style-cite-note style)))
(unless (or (and internal-links (not (memq internal-links '(auto bib-links))))
(and note-style (eq mode 'bib) (or (null internal-links)
(eq internal-links 'auto))))
(let* ((itemid-attr
(if (and note-style (not (eq internal-links 'bib-links)))
;; For note styles link subsequent cites to the first ones
(if (eq (alist-get 'position var-alist) 'first)
'bib-item-no
'cited-item-no)
;; Else link each cite to the corresponding bib item
(if (eq mode 'cite) 'cited-item-no 'bib-item-no)))
(itemid-attr-val (cons itemid-attr
(alist-get 'citation-number var-alist))))
(cond ((consp rendered) (setf (car rendered)
(-snoc (car rendered) itemid-attr-val)))
((stringp rendered) (setq rendered
(list (list itemid-attr-val) rendered)))))))
;; Add appropriate item-no information
(when-let* ((cite-no-attr
(citeproc-context-int-link-attrval
style internal-links mode (alist-get 'position var-alist)))
(cite-no-attr-val (cons cite-no-attr
(alist-get 'citation-number var-alist))))
(cond ((consp rendered) (setf (car rendered)
(-snoc (car rendered) cite-no-attr-val)))
((stringp rendered) (setq rendered
(list (list cite-no-attr-val) rendered)))))
;; Add year-suffix if needed
(-if-let (year-suffix (alist-get 'year-suffix var-alist))
(car (citeproc-rt-add-year-suffix

69
lisp/citeproc/citeproc-formatters.el
View File

@@ -28,6 +28,7 @@
;;; Code:
(require 'let-alist)
(require 'subr-x)
(require 's)
(require 'cl-lib)
@@ -137,15 +138,39 @@ If ANCHOR is string= to TARGET then return ANCHOR."
(href . ,#'citeproc-fmt--org-link)
(cited-item-no . ,(lambda (x y) (concat "[[citeproc_bib_item_" y "][" x "]]")))
(bib-item-no . ,(lambda (x y) (concat "<<citeproc_bib_item_" y ">>" x)))
(font-style-italic . ,(lambda (x) (concat "/" x "/")))
(font-style-oblique . ,(lambda (x) (concat "/" x "/")))
;; Warning: The next four formatter lines put protective zero-width spaces
;; around the Org format characters ('/' etc.).
(font-style-italic . ,(lambda (x) (concat "​/" x "/​")))
(font-style-oblique . ,(lambda (x) (concat "​/" x "/​")))
(font-weight-bold . ,(lambda (x) (concat "​*" x "*​")))
(text-decoration-underline . ,(lambda (x) (concat "​_" x "_​")))
;; End of zero-width space protected formatters.
(font-variant-small-caps . ,(lambda (x) (upcase x)))
(font-weight-bold . ,(lambda (x) (concat "*" x "*")))
(text-decoration-underline . ,(lambda (x) (concat "_" x "_")))
(vertical-align-sub . ,(lambda (x) (concat "_{" x "}")))
(vertical-align-sup . ,(lambda (x) (concat "^{" x "}")))
(display-left-margin . ,(lambda (x) (concat x " ")))))
(defvar citeproc-fmt--org-format-rt-1
(citeproc-formatter-fun-create citeproc-fmt--org-alist)
"Recursive rich-text Org formatter.
Doesn't do finalization by removing zero-width spaces.")
(defun citeproc-fmt--org-format-rt (rt)
"Convert rich-text RT into Org format.
Performs finalization by removing unnecessary zero-width spaces."
(let ((result (funcall citeproc-fmt--org-format-rt-1 rt)))
(when (> (length result) 2)
;; First we remove z-w spaces around spaces and before punctuation.
(setq result (citeproc-s-replace-all-seq
result '((" ​" . " ") ("​ " . " ") ("​," . ",") ("​;" . ";")
("​:" . ":") ("​." . "."))))
;; Starting and ending z-w spaces are also removed.
(when (= (aref result 0) 8203)
(setq result (substring result 1)))
(when (= (aref result (- (length result) 1)) 8203)
(setq result (substring result 0 -1))))
result))
;; HTML
(defun citeproc-fmt--xml-escape (s)
@@ -251,6 +276,36 @@ CSL tests."
(vertical-align-sub . ,(lambda (x) (concat "\\textsubscript{" x "}")))
(font-style-oblique . ,(lambda (x) (concat "\\textsl{" x "}")))))
;; Org-LaTeX
(defconst citeproc-fmt--org-latex-alist
`((unformatted . ,#'citeproc-fmt--latex-escape)
(href . ,#'citeproc-fmt--latex-href)
(font-style-italic . ,(lambda (x) (concat "\\textit{" x "}")))
(font-weight-bold . ,(lambda (x) (concat "\\textbf{" x "}")))
(cited-item-no . ,(lambda (x y) (concat "\\cslcitation{" y "}{" x "}")))
(bib-item-no . ,(lambda (x y) (concat "\\cslbibitem{" y "}{" x "}")))
(font-variant-small-caps . ,(lambda (x) (concat "\\textsc{" x "}")))
(text-decoration-underline . ,(lambda (x) (concat "\\underline{" x "}")))
(vertical-align-sup . ,(lambda (x) (concat "\\textsuperscript{" x "}")))
(display-left-margin . ,(lambda (x) (concat "\\cslleftmargin{" x "}")))
(display-right-inline . ,(lambda (x) (concat "\\cslrightinline{" x "}")))
(display-block . ,(lambda (x) (concat "\\cslblock{" x "}")))
(display-indent . ,(lambda (x) (concat "\\cslindent{" x "}")))
(vertical-align-sub . ,(lambda (x) (concat "\\textsubscript{" x "}")))
(font-style-oblique . ,(lambda (x) (concat "\\textsl{" x "}")))))
(defun citeproc-fmt--org-latex-bib-formatter (items bib-format)
"Return an Org LaTeX bibliography of ITEMS formatted in BIB-FORMAT."
(let-alist bib-format
(let ((hanging-indent (if .hanging-indent "1" "0"))
(entry-spacing (if (and .entry-spacing (<= 1 .entry-spacing))
(number-to-string (- .entry-spacing 1))
"0")))
(concat "\\begin{cslbibliography}{" hanging-indent "}{" entry-spacing "}\n"
(mapconcat #'identity items "\n\n")
"\n\n\\end{cslbibliography}\n"))))
;; Org-ODT
(defconst citeproc-fmt--org-odt-alist
@@ -311,8 +366,10 @@ CSL tests."
:bib #'citeproc-fmt--html-bib-formatter
:no-external-links t))
(raw . ,(citeproc-formatter-create :rt #'identity :bib (lambda (x _) x)))
(org . ,(citeproc-formatter-create
:rt (citeproc-formatter-fun-create citeproc-fmt--org-alist)))
(org . ,(citeproc-formatter-create :rt #'citeproc-fmt--org-format-rt))
(org-latex . ,(citeproc-formatter-create
:rt (citeproc-formatter-fun-create citeproc-fmt--org-latex-alist)
:bib #'citeproc-fmt--org-latex-bib-formatter))
(latex . ,(citeproc-formatter-create
:rt (citeproc-formatter-fun-create citeproc-fmt--latex-alist)))
(plain . ,(citeproc-formatter-create :rt #'citeproc-rt-to-plain

41
lisp/citeproc/citeproc-generic-elements.el
View File

@@ -111,8 +111,8 @@
content)))
(-when-let (match-pos
(and .prefix (s-matched-positions-all
citeproc-generic-elements--url-prefix-re
.prefix)))
citeproc-generic-elements--url-prefix-re
.prefix)))
;; If the prefix ends with an URL then it is moved
;; from the prefix to the rendered variable
;; content.
@@ -124,24 +124,27 @@
;; Don't report empty var for year-suffix, see issue #70.
((not (string= .variable "year-suffix")) (setq type 'empty-vars)))))
(.term (setq .form (if .form (intern .form) 'long)
.plural (if (or (not .plural)
(string= .plural "false"))
'single 'multiple)
content (let ((cont (citeproc-term-inflected-text
.term .form .plural context)))
;; Annotate the 'no date' term as if it'd be
;; the value of the 'issue' variable to
;; handle implicit year suffix addition
;; and suppression issues.
(if (string= .term "no date")
(progn
(setq type 'present-var)
`(((rendered-var . issued)) ,cont))
cont))))
.plural (if (or (not .plural)
(string= .plural "false"))
'single 'multiple)
content (let ((cont (citeproc-term-inflected-text
.term .form .plural context)))
;; Annotate the 'no date' term as if it'd be
;; the value of the 'issue' variable to
;; handle implicit year suffix addition and
;; suppression issues.
(if (string= .term "no date")
(progn
(setq type 'present-var)
`(((rendered-var . issued)) ,cont))
cont))))
(.macro (let ((macro-val (citeproc-macro-output .macro context)))
(setq content (car macro-val))
(setq type (cdr macro-val)))))
(cons (citeproc-rt-format-single attrs content context) type))))
(setq content (car macro-val))
(setq type (cdr macro-val)))))
;; We stop if only the title had to be rendered.
(let ((result (cons (citeproc-rt-format-single attrs content context) type)))
(citeproc-lib-maybe-stop-rendering
'title context result (or (and .variable (intern .variable)) t))))))
(provide 'citeproc-generic-elements)

20
lisp/citeproc/citeproc-itemgetters.el
View File

@@ -153,16 +153,26 @@ without a `langid' field are not converted to sentence-case."
(org-map-entries
(lambda ()
(-when-let (key-w-entry (citeproc-bt-from-org-headline))
(puthash (car key-w-entry) (citeproc-bt-entry-to-csl
(cdr key-w-entry))
cache)))
(condition-case err
(puthash (car key-w-entry) (citeproc-blt-entry-to-csl
(cdr key-w-entry))
cache)
(error
(user-error
"Couldn't parse the bib(la)tex entry with key '%s', the error was: %s"
(car key-w-entry) err)))))
t (list file)))
(ext
(user-error "Unknown bibliography extension: %S" ext))))
(maphash
(lambda (key entry)
(puthash key (citeproc-blt-entry-to-csl entry nil no-sentcase-wo-langid)
cache))
(condition-case err
(puthash key (citeproc-blt-entry-to-csl entry nil no-sentcase-wo-langid)
cache)
(error
(user-error
"Couldn't parse the bib(la)tex entry with key '%s', the error was: %s"
key err))))
bt-entries)
(lambda (x)
(pcase x

4
lisp/citeproc/citeproc-locale.el
View File

@@ -1,6 +1,6 @@
;; citeproc-locale.el --- CSL locale related functions -*- lexical-binding: t; -*-
;; Copyright (C) 2017 András Simonyi
;; Copyright (C) 2017-2022 András Simonyi
;; Author: András Simonyi <andras.simonyi@gmail.com>
@@ -41,7 +41,7 @@
("ko" . "KR") ("nb" . "NO") ("nn" . "NO") ("sl" . "SI")
("sr" . "RS") ("sv" . "SE") ("uk" . "UA") ("vi" . "VN")
("zh" . "CN"))
"Alist mapping those locales to their default variants.
"Alist mapping locales to their default variants.
Only those locales are given for which the default variant is not
simply the result of upcasing.")

72
lisp/citeproc/citeproc-name.el
View File

@@ -36,6 +36,17 @@
(require 'citeproc-context)
(require 'citeproc-term)
(defvar citeproc-name-postprocess-functions nil
"A list of functions to postprocess rendered names.
Each function takes three arguments:
- the rich-text rendering of a name to be post-processed,
- the rendered name as an alist with CSL name-part
keys (`family', `given' etc.), and
- the rendering context, as a `citeproc-context' structure.
The output of each function should be the post-processed
rich-text, and the functions are applied in the order they appear
in the list.")
;; OPTIMIZE: Name count could be sped up by only counting the names to be
;; rendered without actually rendering them
(defun citeproc-name-render-vars
@@ -103,12 +114,9 @@ Nature."
(push `(plural . ,(if (> (length var-value) 1) "always" "never"))
label-attrs)))
(if with-label
(let ((form (alist-get 'form label-attrs))
(rendered-label (car (citeproc--label label-attrs context))))
(let ((rendered-label (car (citeproc--label label-attrs context))))
(citeproc-rt-join-formatted `((rendered-var . ,var))
(if (or label-before-names
(string= form "verb")
(string= form "verb-short"))
(if label-before-names
(list rendered-label rendered-names)
(list rendered-names rendered-label))
context))
@@ -208,15 +216,18 @@ Nature."
(defun citeproc-name--render (name attrs name-part-attrs sort-o context)
"Render NAME according to the given attributes."
(let ((format-attrs
(--filter (memq (car it) (-concat '(prefix suffix) citeproc-rt-format-attrs))
attrs)))
(citeproc-rt-format-single
(cons `(name-id . ,(alist-get 'name-id name)) format-attrs)
(citeproc-name--render-formatted
(citeproc-name--format-nameparts name name-part-attrs context)
attrs sort-o context)
context)))
(let* ((format-attrs
(--filter (memq (car it) (-concat '(prefix suffix) citeproc-rt-format-attrs))
attrs))
(result (citeproc-rt-format-single
(cons `(name-id . ,(alist-get 'name-id name)) format-attrs)
(citeproc-name--render-formatted
(citeproc-name--format-nameparts name name-part-attrs context)
attrs sort-o context)
context)))
(dolist (fn citeproc-name-postprocess-functions)
(setq result (funcall fn result name context)))
result))
(defun citeproc-name--parts-w-sep (c1 c2 sep context)
"Join name-parts in lists C1 C2 with spaces and then with SEP."
@@ -232,7 +243,7 @@ Nature."
(defun citeproc-name--render-formatted (name-alist attrs sort-o context)
"Render formatted name described by NAME-ALIST according to ATTRS.
NAME-ALIST is an alist with symbol keys corresponding to
name-parts like 'family etc. and values are simple rich-text
name-parts like `family' etc. and values are simple rich-text
contents of the form (ATTRS CONTENT) where content must be a
single string. SORT-O is a boolean determining whether to use
sort order."
@@ -260,7 +271,9 @@ sort order."
(rmode (citeproc-context-render-mode context)))
(if (citeproc-name--lat-cyr-greek-p name-alist)
(let ((g
(cond ((and show-given (= show-given 2)) g-uninited)
(cond ((or (null g-uninited)
(and show-given (= show-given 2)))
g-uninited)
((and init-with init)
(list (citeproc-rt-attrs g-uninited)
(citeproc-name--initialize
@@ -318,8 +331,6 @@ NAME-ALIST is like in `citeproc-name--render-formatted'"
(cdr x)))
name-alist)))
;;NOTE: missing given names are currently dealt here by handling the names =
;;nil case there should be a more appropriate place.
(defun citeproc-name--initialize (names suffix &optional remove-hyphens)
"Initialize NAMES and add SUFFIX.
NAMES is a string containing one or more space-separated names,
@@ -327,16 +338,15 @@ while SUFFIX is either nil or a string (e.g. \".\"). If the
optional REMOVE-HYPHENS is non-nil then don't keep hyphens
between initalized given names, e.g., initialize Jean-Paul to
J.P. instead of the default J.-P."
(if (not names) nil
(let ((trimmed-suffix (s-trim suffix)))
(concat (s-join
suffix
(--map
(if (s-match "-" it)
(citeproc-name--initialize-hyphenated it suffix remove-hyphens)
(s-left 1 it))
(s-split " +" names)))
trimmed-suffix))))
(let ((trimmed-suffix (s-trim suffix)))
(concat (s-join
suffix
(--map
(if (s-match "-" it)
(citeproc-name--initialize-hyphenated it suffix remove-hyphens)
(s-left 1 it))
(s-split " +" names)))
trimmed-suffix)))
(defun citeproc-name--initialize-hyphenated (name suffix &optional remove-hyphens)
"Initialize space-less but hyphenated NAME with SUFFIX.
@@ -396,7 +406,7 @@ contents."
(defun citeproc--var-plural-p (var context)
"Return whether the content of variable VAR is plural.
VAR is a symbol."
(let ((content (citeproc-var-value var context)))
(let ((content (citeproc-rt-to-plain (citeproc-var-value var context))))
(if (or (string= var "number-of-pages")
(string= var "number-of-volumes"))
(> (string-to-number content) 1)
@@ -427,6 +437,10 @@ VAR is a symbol."
(if (citeproc--var-plural-p label context)
'multiple
'single))))
;; Add rendered locator label info in cite mode.
(when (and (eq label 'locator)
(eq (citeproc-context-mode context) 'cite))
(push '(rendered-locator-label . t) attrs))
(cons (citeproc-rt-format-single attrs (citeproc-term-inflected-text
variable form number context)
context)

6
lisp/citeproc/citeproc-pkg.el
View File

@@ -1,5 +1,5 @@
(define-package "citeproc" "20220101.1527" "A CSL 1.0.2 Citation Processor"
'((emacs "25")
(define-package "citeproc" "20221216.1238" "A CSL 1.0.2 Citation Processor"
'((emacs "26")
(dash "2.13.0")
(s "1.12.0")
(f "0.18.0")
@@ -7,7 +7,7 @@
(string-inflection "1.0")
(org "9")
(parsebib "2.4"))
:commit "abf3e45946598dffebfba6d6bd9a8cda46815765" :authors
:commit "3cb83db147bdda208520246e82dbf9878fa3cbd0" :authors
'(("András Simonyi" . "andras.simonyi@gmail.com"))
:maintainer
'("András Simonyi" . "andras.simonyi@gmail.com")

26
lisp/citeproc/citeproc-proc.el
View File

@@ -158,6 +158,19 @@ Return the itemdata struct that was added."
(setf (citeproc-itemdata-occurred-before itd) nil))
(citeproc-proc-itemdata proc)))
(defun citeproc-proc--parse-csl-json-name (rep)
"Parse the json representation REP of a csl name variable."
(if-let ((literal (alist-get 'literal rep)))
(list (cons 'family (citeproc-s-smart-apostrophes literal)))
(let ((filtered (-remove (lambda (x) (eq (car x) 'isInstitution)) rep)))
(--map (cons
(car it)
(let ((text-field (cdr it)))
(if (stringp text-field)
(citeproc-s-smart-apostrophes text-field)
text-field)))
filtered))))
(defun citeproc-proc--parse-csl-var-val (rep var proc)
"Parse the json representation REP of csl variable VAR.
VAR is a csl variable as symbol;
@@ -166,16 +179,9 @@ REP is its value in standard csl json representation as parsed by
PROC is the target citeproc-processor of the internal representation.
Return the PROC-internal representation of REP."
(cond ((memq var citeproc--name-vars)
(--map
(let* ((filtered (-remove (lambda (x) (eq (car x) 'isInstitution)) it))
(w-smart-aposts (--map (cons
(car it)
(let ((text-field (cdr it)))
(if (stringp text-field)
(citeproc-s-smart-apostrophes text-field)
text-field)))
filtered)))
(citeproc-proc--internalize-name w-smart-aposts proc))
(--map (citeproc-proc--internalize-name
(citeproc-proc--parse-csl-json-name it)
proc)
rep))
((memq var citeproc--date-vars)
(citeproc-date-parse rep))

87
lisp/citeproc/citeproc-rt.el
View File

@@ -43,7 +43,7 @@
(defconst citeproc-rt-format-attrs
'(font-variant font-style font-weight text-decoration vertical-align font-variant
display rendered-var name-id quotes cited-item-no bib-item-no
rendered-names href stopped-rendering)
rendered-names href stopped-rendering rendered-locator-label)
"The rich-text content format attributes (used in raw output).")
(defconst citeproc-rt-ext-format-attrs
@@ -142,7 +142,7 @@ If optional SKIP-NOCASE is non-nil then skip spans with the
(_ (funcall fun rt))))
(defun citeproc-rt-replace-all-sim (replacements regex rts)
"Make all REPLACEMENTS sequentially in the strings of rich-texts RTS."
"Make all REPLACEMENTS simultaneously in the strings of rich-texts RTS."
(citeproc-rt-map-strings (lambda (x) (citeproc-s-replace-all-sim x regex replacements))
rts))
@@ -276,7 +276,8 @@ on any dominated branch for which PRED holds."
((sc . nil) . (font-variant . "small-caps"))
((sup . nil) . (vertical-align . "sup"))
((sub . nil) . (vertical-align . "sub"))
((span . ((class . "nocase"))) . (nocase . t)))
((span . ((class . "nocase"))) . (nocase . t))
((span . ((class . "underline"))) . (text-decoration . "underline")))
"A mapping from html tags and attrs to rich text attrs.")
(defun citeproc-rt-from-html (h)
@@ -564,6 +565,86 @@ modified bibliography."
(push (cons 'href target) (car node))))
(citeproc-rt-transform-first r #'rendered-var-title-p #'add-link)))
(defun citeproc-rt-locator-p (r)
"Return whether rich-text R is a rendered locator."
(and (consp r) (string= (alist-get 'rendered-var (car r)) "locator")))
(defun citeproc-rt-locator-label-p (r)
"Return whether rich-text R is a rendered locator label."
(and (consp r) (alist-get 'rendered-locator-label (car r))))
(defun citeproc-rt-add-locator-label-position (r)
"Add information about locator-label position in rich-text R.
Return value is one of `label', `locator', `label-first',
`locator-first', `label-only', `locator-only' or nil. This
information is also added to the tree node attributes."
(let ((result
(cond
((not (consp r)) nil)
((citeproc-rt-locator-p r) 'locator)
((citeproc-rt-locator-label-p r) 'label)
(t (let ((content (cdr r))
first second)
(while (and content (not (and first second)))
(let* ((cur (pop content))
(cur-order (citeproc-rt-add-locator-label-position cur)))
(pcase cur-order
('label-first (setq first 'label second 'locator))
('locator-first (setq first 'locator second 'label))
((or 'label-only 'label)
(if first (setq second 'label)
(setq first 'label)))
((or 'locator-only 'locator)
(if first (setq second 'locator)
(setq first 'locator))))))
(cond
((not first) nil)
((not second) (if (eq first 'locator) 'locator-only 'label-only))
(t (if (eq first 'locator) 'locator-first 'label-first))))))))
(when result (push (cons 'l-l-pos result) (car r)))
result))
(defun citeproc-rt-locator-w-label (r)
"Return locator with label if found from rich-text R.
Return R if no locator or locator label was found."
(let ((l-l-pos (citeproc-rt-add-locator-label-position r)))
(if l-l-pos
(citeproc-rt-locator-w-label-1 r l-l-pos)
;; We return the full cite if no locator was found.
r)))
(defun citeproc-rt-locator-w-label-1 (r l-l-pos)
"Return locator-label span from rich-text fragment R.
L-L-POS is the global position of locator and label, see the
documentation of `citeproc-rt-add-locator-label-position' for the
possible values."
(if (or (citeproc-rt-locator-label-p r) (citeproc-rt-locator-p r)) r
(pcase-let* ((`(,attrs . ,content) r)
(local-llpos (alist-get 'l-l-pos attrs)))
(cons attrs
(let (result
(n-boundaries (if (or (and (eq l-l-pos 'locator-first)
(eq local-llpos 'label-only))
(and (eq l-l-pos 'label-first)
(eq local-llpos 'locator-only)))
1 ; Fragment starts in a between position.
0))) ; Fragment starts in a before position.
(while (and content (< n-boundaries 2))
(let* ((cur-rt (pop content))
(cur-rt-llpos (and (consp cur-rt) (alist-get 'l-l-pos (car cur-rt)))))
(cond (cur-rt-llpos
;; Element at boundary
(cl-incf n-boundaries
(if (or (eq l-l-pos 'locator-only)
(memq cur-rt-llpos '(label-first locator-first)))
2
1))
(push (citeproc-rt-locator-w-label-1 cur-rt l-l-pos) result))
;; Element in between position, simply pushing
((= n-boundaries 1)
(push cur-rt result)))))
(nreverse result))))))
(provide 'citeproc-rt)
;;; citeproc-rt.el ends here

4
lisp/citeproc/citeproc-s.el
View File

@@ -244,8 +244,8 @@ REPLACEMENTS is an alist with (FROM . TO) elements."
(defun citeproc-s-smart-apostrophes (s)
"Replace dumb apostophes in string S with smart ones.
The replacement character used is the unicode character 'modifier
letter apostrophe.'"
The replacement character used is the unicode character `modifier
letter apostrophe'."
(subst-char-in-string ?' ?ʼ (subst-char-in-string ?’ ?ʼ s t) t))
(defconst citeproc-s--cull-spaces-alist

4
lisp/citeproc/citeproc-style.el
View File

@@ -120,8 +120,8 @@ in-style locale information will be loaded (if available)."
(defun citeproc-style--parse-layout-and-sort-frag (frag)
"Parse a citation or bibliography style xml FRAG.
Return an alist with keys 'layout, 'opts, 'layout-attrs, 'sort
and 'sort-orders."
Return an alist with keys `layout', `opts', `layout-attrs', `sort'
and `sort-orders'."
(let* ((opts (cadr frag))
(sort-p (eq (cl-caaddr frag) 'sort))
(layout (citeproc-style--transform-xmltree

22
lisp/citeproc/citeproc-subbibs.el
View File

@@ -1,6 +1,6 @@
;;; citeproc-subbibs.el --- support for subbibliographies -*- lexical-binding: t; -*-
;; Copyright (C) 2021 András Simonyi
;; Copyright (C) 2021-2022 András Simonyi
;; Author: András Simonyi <andras.simonyi@gmail.com>
@@ -30,19 +30,25 @@
(require 'citeproc-proc)
(require 'citeproc-itemdata)
(defun citeproc-sb-match-p (vv filter &optional use-blt-type)
"Return whether var-vals alist VV matches FILTER.
If optional USE-BLT-TYPE is non-nil then use the value for key
`blt-type' to evaluate type-based filter parts."
(let* ((type (alist-get (if use-blt-type 'blt-type 'type) vv))
(defun citeproc-sb--match-p (vv filter)
"Return whether var-vals alist VV matches all conditions in FILTER.
FILTER should be an alist containing symbol keys and string
values, each pair describing an atomic condition to be
satisified. For a list and description of the supported keys
see the documentation of `citeproc-add-subbib-filters'."
(let* ((csl-type (alist-get 'type vv))
(type (or (alist-get 'blt-type vv) csl-type))
(keyword (alist-get 'keyword vv))
(keywords (and keyword (split-string keyword "[ ,;]" t))))
(--every-p
(pcase it
(`(type . ,key) (string= type key))
(`(nottype . ,key) (not (string= type key)))
(`(keyword . ,key) (member key keywords))
(`(keyword . ,key) (member key keywords))
(`(notkeyword . ,key) (not (member key keywords)))
(`(filter . ,key) (funcall (intern key) vv))
(`(csltype . ,key) (string= csl-type key))
(`(notcsltype . ,key) (not (string= csl-type key)))
(`(,key . ,_) (error "Unsupported Citeproc filter keyword `%s'" key)))
filter)))
@@ -55,7 +61,7 @@ If optional USE-BLT-TYPE is non-nil then use the value for key
(subbib-nos
(-non-nil
(--map-indexed
(when (citeproc-sb-match-p varvals it) it-index)
(when (citeproc-sb--match-p varvals it) it-index)
filters))))
(setf (citeproc-itemdata-subbib-nos itemdata) subbib-nos)))
(citeproc-proc-itemdata proc))))

63
lisp/citeproc/citeproc.el
View File

@@ -1,12 +1,12 @@
;;; citeproc.el --- A CSL 1.0.2 Citation Processor -*- lexical-binding: t; -*-
;; Copyright (C) 2017-2021 András Simonyi
;; Copyright (C) 2017-2022 András Simonyi
;; Author: András Simonyi <andras.simonyi@gmail.com>
;; Maintainer: András Simonyi <andras.simonyi@gmail.com>
;; URL: https://github.com/andras-simonyi/citeproc-el
;; Keywords: bib
;; Package-Requires: ((emacs "25") (dash "2.13.0") (s "1.12.0") (f "0.18.0") (queue "0.2") (string-inflection "1.0") (org "9") (parsebib "2.4"))
;; Package-Requires: ((emacs "26") (dash "2.13.0") (s "1.12.0") (f "0.18.0") (queue "0.2") (string-inflection "1.0") (org "9") (parsebib "2.4"))
;; Version: 0.9
;; This program is free software; you can redistribute it and/or modify
@@ -105,10 +105,24 @@ effect of adding all items available in the itemgetter."
(setf (citeproc-proc-finalized proc) nil))
(defun citeproc-add-subbib-filters (filters proc)
"Add subbib FILTERS to PROC.
FILTERS should be a list of alists in which the keys are one of
the symbols `type', `nottype', `keyword', `notkeyword', and
values are strings."
"Add sub-bibliography FILTERS to PROC.
FILTERS should be a list of alists containing symbol keys and
string values, each pair describing an atomic condition to be
satisified by the printed entries. The following keys are
supported:
- `type': print only entries of the given type. Type is the
bib(la)tex entry type if available, otherwise the CSL type is
used as fallback;
- `nottype': print only entries not of the given type. Type is
the bib(la)tex entry type if available, otherwise the CSL type
is used as fallback;
- `csltype', `notcsltype': same as `type' and `nottype' but uses
the entries' CSL type even if the bib(la)tex type is also
available;
- `keyword': print only entries with the given keyword;
- `notkeyword': print only entries without the given keyword;
- `filter': print only entries for which the function named by
the key returns a non-nil value."
(setf (citeproc-proc-bib-filters proc) filters
(citeproc-proc-finalized proc) nil))
@@ -182,23 +196,36 @@ formatting parameters keyed to the parameter names as symbols:
punct-in-quote)))
itemdata)
(let* ((raw-bib
(if filters
;; There are filters, we need to select and sort the subbibs.
(let ((result (make-list (length filters) nil))
(bib-sort (citeproc-style-bib-sort (citeproc-proc-style proc))))
(if (cdr filters)
;; There are several filters, we need to select and sort the subbibs.
(let* ((nr-of-filters (length filters))
(result (make-list nr-of-filters nil))
;; We store boolean to-be-sorted flags for each sub-bib
(to-be-sorted (make-bool-vector nr-of-filters nil))
(bib-sort (citeproc-style-bib-sort (citeproc-proc-style proc))))
;; Put the itds into subbib lists.
(maphash
(lambda (_ itd)
(dolist (subbib-no (citeproc-itemdata-subbib-nos itd))
(push itd (elt result subbib-no))))
(let ((subbib-nos (citeproc-itemdata-subbib-nos itd)))
;; Set to-be-sorted for later subbibs if itemdata
;; occcurs in more than one.
(when-let ((later-subbib-nos (cdr subbib-nos)))
(dolist (subbib-no later-subbib-nos)
(setf (elt to-be-sorted subbib-no) t)))
;; Push the item in all corresponding subbibs.
(dolist (subbib-no subbib-nos)
(push itd (elt result subbib-no)))))
itemdata)
;; Sort the itds in each list according to the sort settings
;; Sort the itds in each individual list
(setq result
(--map (if bib-sort
(citeproc-sort-itds it (citeproc-style-bib-sort-orders
(citeproc-proc-style proc)))
(citeproc-sort-itds-on-citnum it))
result))
(--map-indexed
(if (and bib-sort (elt to-be-sorted it-index))
;; Subbib contains earlier item, needs to sorted.
(citeproc-sort-itds it (citeproc-style-bib-sort-orders
(citeproc-proc-style proc)))
;; No earlier item, sorting on citation-number.
(citeproc-sort-itds-on-citnum it))
result))
;; Generate the raw bibs.
(--map (mapcar #'citeproc-itemdata-rawbibitem it) result))
;; No filters, so raw-bib is a list containg a single raw bibliograhy.

1
lisp/cl-libify.el
View File

@@ -4,6 +4,7 @@
;; Author: Steve Purcell <steve@sanityinc.com>
;; Keywords: lisp
;; Package-Commit: e205b96f944a4f312fd523804cbbaf00027a3c8b
;; Homepage: https://github.com/purcell/cl-libify
;; Package-Requires: ((emacs "25"))
;; Package-Version: 20181130.230

2
lisp/company-ledger.el
View File

@@ -6,7 +6,7 @@
;; Description: Fuzzy auto-completion for ledger & friends
;; Keywords: abbrev, matching, auto-complete, beancount, ledger, company
;; Package-Version: 20210910.250
;; Package-Commit: c6911b7e39b29c0d5f2541392ff485b0f53fd366
;; Package-Commit: 55fdddd6c5e9c061c685b474ef5e148a4ac9b576
;; Version: 0.1.0
;; Package-Requires: ((emacs "24.3") (company "0.8.0"))
;; URL: https://github.com/debanjum/company-ledger

12
lisp/company-quickhelp.el
View File

@@ -4,8 +4,8 @@
;; Author: Lars Andersen <expez@expez.com>
;; URL: https://www.github.com/expez/company-quickhelp
;; Package-Version: 20211115.1335
;; Package-Commit: 3ca2708b4e5190205aca01d65fe1b391963a53f9
;; Package-Version: 20221212.534
;; Package-Commit: 9505fb09d064581da142d75c139d48b5cf695bd5
;; Keywords: company popup documentation quickhelp
;; Version: 2.2.0
;; Package-Requires: ((emacs "24.3") (company "0.8.9") (pos-tip "0.4.6"))
@@ -100,7 +100,7 @@ be triggered manually using `company-quickhelp-show'."
(defun company-quickhelp--skip-footers-backwards ()
"Skip backwards over footers and blank lines."
(beginning-of-line)
(while (and (not (= (point-at-eol) (point-min)))
(while (and (not (= (line-end-position) (point-min)))
(or
;; [back] appears at the end of the help elisp help buffer
(looking-at-p "\\[back\\]")
@@ -119,9 +119,9 @@ be triggered manually using `company-quickhelp-show'."
"Fetch docstring from START."
(goto-char start)
(company-quickhelp--goto-max-line)
(let ((truncated (< (point-at-eol) (point-max))))
(let ((truncated (< (line-end-position) (point-max))))
(company-quickhelp--skip-footers-backwards)
(list :doc (buffer-substring start (point-at-eol))
(list :doc (buffer-substring start (line-end-position))
:truncated truncated)))
(defun company-quickhelp--completing-read (prompt candidates &rest rest)
@@ -175,9 +175,9 @@ currently active `company' completion candidate."
(pos-tip-hide)))
(defun company-quickhelp--show ()
(company-quickhelp--cancel-timer)
(when (and (company-quickhelp-pos-tip-available-p)
company-selection)
(company-quickhelp--cancel-timer)
(while-no-input
(let* ((selected (nth company-selection company-candidates))
(doc (let ((inhibit-message t))

5
lisp/company-web/company-web-html.el
View File

@@ -27,11 +27,6 @@
(require 'company-web)
(defcustom company-web-html-emmet-enable t
"Enable emmet specified completion when `emmet-mode' active."
:group 'company-web
:type 'boolean)
(defcustom company-web-html-emmet-enable t
"Enable emmet specified completion when `emmet-mode' active."
:group 'company-web

8
lisp/company-web/company-web-pkg.el
View File

@@ -1,14 +1,14 @@
(define-package "company-web" "20180402.1155" "Company version of ac-html, complete for web,html,emmet,jade,slim modes"
(define-package "company-web" "20220115.2146" "Company version of ac-html, complete for web,html,emmet,jade,slim modes"
'((company "0.8.0")
(dash "2.8.0")
(cl-lib "0.5.0")
(web-completion-data "0.1.0"))
:commit "f0cc9187c9c34f72ad71f5649a69c74f996bae9a" :keywords
'("html" "company")
:authors
:commit "e0c6bfa3ae7006c73d0fdfc0fdb69816309baf1b" :authors
'(("Olexandr Sydorchuk" . "olexandr.syd@gmail.com"))
:maintainer
'("Olexandr Sydorchuk" . "olexandr.syd@gmail.com")
:keywords
'("html" "company")
:url "https://github.com/osv/company-web")
;; Local Variables:
;; no-byte-compile: t

2
lisp/company/company-abbrev.el
View File

@@ -1,6 +1,6 @@
;;; company-abbrev.el --- company-mode completion backend for abbrev
;; Copyright (C) 2009-2011, 2015, 2021 Free Software Foundation, Inc.
;; Copyright (C) 2009-2011, 2013-2015, 2021 Free Software Foundation, Inc.
;; Author: Nikolaj Schumacher

2
lisp/company/company-bbdb.el
View File

@@ -1,6 +1,6 @@
;;; company-bbdb.el --- company-mode completion backend for BBDB in message-mode
;; Copyright (C) 2013-2014, 2016 Free Software Foundation, Inc.
;; Copyright (C) 2013-2016, 2020 Free Software Foundation, Inc.
;; Author: Jan Tatarik <jan.tatarik@gmail.com>

50
lisp/company/company-capf.el
View File

@@ -1,6 +1,6 @@
;;; company-capf.el --- company-mode completion-at-point-functions backend -*- lexical-binding: t -*-
;; Copyright (C) 2013-2019, 2021 Free Software Foundation, Inc.
;; Copyright (C) 2013-2021 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
@@ -57,19 +57,43 @@ so we can't just use the preceding variable instead.")
(list (current-buffer) (point) (buffer-chars-modified-tick) data))
data))))
(defun company--contains (elt lst)
(when-let ((cur (car lst)))
(cond
((symbolp cur)
(or (eq elt cur)
(company--contains elt (cdr lst))))
((listp cur)
(or (company--contains elt cur)
(company--contains elt (cdr lst)))))))
(defun company--capf-data-real ()
(cl-letf* (((default-value 'completion-at-point-functions)
;; Ignore tags-completion-at-point-function because it subverts
;; company-etags in the default value of company-backends, where
;; the latter comes later.
(remove 'tags-completion-at-point-function
(default-value 'completion-at-point-functions)))
(if (company--contains 'company-etags company-backends)
;; Ignore tags-completion-at-point-function because it subverts
;; company-etags in the default value of company-backends, where
;; the latter comes later.
(remove 'tags-completion-at-point-function
(default-value 'completion-at-point-functions))
(default-value 'completion-at-point-functions)))
(completion-at-point-functions (company--capf-workaround))
(data (run-hook-wrapped 'completion-at-point-functions
;; Ignore misbehaving functions.
#'completion--capf-wrapper 'optimist)))
#'company--capf-wrapper 'optimist)))
(when (and (consp (cdr data)) (integer-or-marker-p (nth 1 data))) data)))
(defun company--capf-wrapper (fun which)
(let ((buffer-read-only t)
(inhibit-read-only nil)
(completion-in-region-function
(lambda (beg end coll pred)
(throw 'company--illegal-completion-in-region
(list fun beg end coll :predicate pred)))))
(catch 'company--illegal-completion-in-region
(condition-case nil
(completion--capf-wrapper fun which)
(buffer-read-only nil)))))
(declare-function python-shell-get-process "python")
(defun company--capf-workaround ()
@@ -165,8 +189,16 @@ so we can't just use the preceding variable instead.")
))
(defun company-capf--annotation (arg)
(let* ((f (plist-get (nthcdr 4 company-capf--current-completion-data)
:annotation-function))
(let* ((f (or (plist-get (nthcdr 4 company-capf--current-completion-data)
:annotation-function)
;; FIXME: Add a test.
(cdr (assq 'annotation-function
(completion-metadata
(buffer-substring (nth 1 company-capf--current-completion-data)
(nth 2 company-capf--current-completion-data))
(nth 3 company-capf--current-completion-data)
(plist-get (nthcdr 4 company-capf--current-completion-data)
:predicate))))))
(annotation (when f (funcall f arg))))
(if (and company-format-margin-function
(equal annotation " <f>") ; elisp-completion-at-point, pre-icons

4
lisp/company/company-clang.el
View File

@@ -1,6 +1,6 @@
;;; company-clang.el --- company-mode completion backend for Clang -*- lexical-binding: t -*-
;; Copyright (C) 2009, 2011, 2013-2019 Free Software Foundation, Inc.
;; Copyright (C) 2009-2011, 2013-2021 Free Software Foundation, Inc.
;; Author: Nikolaj Schumacher
@@ -357,7 +357,7 @@ or automatically through a custom `company-clang-prefix-guesser'."
(string-to-number (match-string-no-properties 2)))
0)))
(defun company-clang (command &optional arg &rest ignored)
(defun company-clang (command &optional arg &rest _ignored)
"`company-mode' completion backend for Clang.
Clang is a parser for C and ObjC. Clang version 1.1 or newer is required.

2
lisp/company/company-cmake.el
View File

@@ -1,6 +1,6 @@
;;; company-cmake.el --- company-mode completion backend for CMake
;; Copyright (C) 2013-2014, 2017-2018 Free Software Foundation, Inc.
;; Copyright (C) 2013-2015, 2017-2018, 2020 Free Software Foundation, Inc.
;; Author: Chen Bin <chenbin DOT sh AT gmail>
;; Version: 0.2

4
lisp/company/company-css.el
View File

@@ -1,6 +1,6 @@
;;; company-css.el --- company-mode completion backend for css-mode -*- lexical-binding: t -*-
;; Copyright (C) 2009, 2011, 2014, 2018 Free Software Foundation, Inc.
;; Copyright (C) 2009-2011, 2013-2015, 2018 Free Software Foundation, Inc.
;; Author: Nikolaj Schumacher
@@ -414,7 +414,7 @@ Returns \"\" if no property found, but feasible at this position."
"A regular expression matching CSS tags.")
;;;###autoload
(defun company-css (command &optional arg &rest ignored)
(defun company-css (command &optional arg &rest _ignored)
"`company-mode' completion backend for `css-mode'."
(interactive (list 'interactive))
(cl-case command

4
lisp/company/company-dabbrev-code.el
View File

@@ -1,6 +1,6 @@
;;; company-dabbrev-code.el --- dabbrev-like company-mode backend for code -*- lexical-binding: t -*-
;; Copyright (C) 2009, 2011, 2014 Free Software Foundation, Inc.
;; Copyright (C) 2009-2011, 2013-2016, 2021 Free Software Foundation, Inc.
;; Author: Nikolaj Schumacher
@@ -76,7 +76,7 @@ also `company-dabbrev-code-time-limit'."
"\\(\\sw\\|\\s_\\)*\\_>"))
;;;###autoload
(defun company-dabbrev-code (command &optional arg &rest ignored)
(defun company-dabbrev-code (command &optional arg &rest _ignored)
"dabbrev-like `company-mode' backend for code.
The backend looks for all symbols in the current buffer that aren't in
comments or strings."

4
lisp/company/company-dabbrev.el
View File

@@ -1,6 +1,6 @@
;;; company-dabbrev.el --- dabbrev-like company-mode completion backend -*- lexical-binding: t -*-
;; Copyright (C) 2009, 2011, 2014, 2015, 2016 Free Software Foundation, Inc.
;; Copyright (C) 2009-2011, 2013-2018, 2021 Free Software Foundation, Inc.
;; Author: Nikolaj Schumacher
@@ -179,7 +179,7 @@ This variable affects both `company-dabbrev' and `company-dabbrev-code'."
(all-completions prefix candidates)))
;;;###autoload
(defun company-dabbrev (command &optional arg &rest ignored)
(defun company-dabbrev (command &optional arg &rest _ignored)
"dabbrev-like `company-mode' completion backend."
(interactive (list 'interactive))
(cl-case command

4
lisp/company/company-elisp.el
View File

@@ -1,6 +1,6 @@
;;; company-elisp.el --- company-mode completion backend for Emacs Lisp -*- lexical-binding: t -*-
;; Copyright (C) 2009, 2011-2013, 2017 Free Software Foundation, Inc.
;; Copyright (C) 2009-2015, 2017, 2020 Free Software Foundation, Inc.
;; Author: Nikolaj Schumacher
@@ -193,7 +193,7 @@ first in the candidates list."
(match-string 0 doc))))
;;;###autoload
(defun company-elisp (command &optional arg &rest ignored)
(defun company-elisp (command &optional arg &rest _ignored)
"`company-mode' completion backend for Emacs Lisp."
(interactive (list 'interactive))
(cl-case command

2
lisp/company/company-etags.el
View File

@@ -1,6 +1,6 @@
;;; company-etags.el --- company-mode completion backend for etags
;; Copyright (C) 2009-2011, 2014 Free Software Foundation, Inc.
;; Copyright (C) 2009-2011, 2013-2015, 2018-2019 Free Software Foundation, Inc.
;; Author: Nikolaj Schumacher

2
lisp/company/company-files.el
View File

@@ -1,6 +1,6 @@
;;; company-files.el --- company-mode completion backend for file names
;; Copyright (C) 2009-2011, 2014-2021 Free Software Foundation, Inc.
;; Copyright (C) 2009-2011, 2013-2021 Free Software Foundation, Inc.
;; Author: Nikolaj Schumacher

2
lisp/company/company-gtags.el
View File

@@ -1,6 +1,6 @@
;;; company-gtags.el --- company-mode completion backend for GNU Global
;; Copyright (C) 2009-2011, 2014-2020 Free Software Foundation, Inc.
;; Copyright (C) 2009-2011, 2013-2021 Free Software Foundation, Inc.
;; Author: Nikolaj Schumacher

2
lisp/company/company-ispell.el
View File

@@ -1,6 +1,6 @@
;;; company-ispell.el --- company-mode completion backend using Ispell
;; Copyright (C) 2009-2011, 2013-2016 Free Software Foundation, Inc.
;; Copyright (C) 2009-2011, 2013-2016, 2018, 2021 Free Software Foundation, Inc.
;; Author: Nikolaj Schumacher

137
lisp/company/company-keywords.el
View File

@@ -1,6 +1,6 @@
;;; company-keywords.el --- A company backend for programming language keywords
;; Copyright (C) 2009-2011, 2016 Free Software Foundation, Inc.
;; Copyright (C) 2009-2011, 2013-2018, 2020-2021 Free Software Foundation, Inc.
;; Author: Nikolaj Schumacher
@@ -61,13 +61,23 @@
"xor" "xor_eq")
(c-mode
;; from https://en.cppreference.com/w/c/keyword
"_Alignas" "_Alignof" "_Atomic" "_Bool" "_Complex" "_Generic" "_Imaginary"
"_Noreturn" "_Static_assert" "_Thread_local"
"_Alignas" "_Alignof" "_Atomic" "_Bool" "_Complex"
"_Decimal128" "_Decimal32" "_Decimal64" "_Generic" "_Imaginary"
"_Noreturn" "_Static_assert" "_Thread_local" "__asm__" "asm"
"auto" "break" "case" "char" "const" "continue" "default" "do"
"double" "else" "enum" "extern" "float" "for" "goto" "if" "inline"
"int" "long" "register" "restrict" "return" "short" "signed" "sizeof"
"static" "struct" "switch" "typedef" "union" "unsigned" "void" "volatile"
"while")
(crystal-mode
;; from https://github.com/crystal-lang/crystal-book/issues/124#issuecomment-1008311227
"abstract" "alias" "annotation" "as" "as?" "asm" "begin" "break" "case" "class"
"def" "do" "else" "elsif" "end" "ensure" "enum" "extend" "false" "for" "fun"
"if" "in" "include" "instance_sizeof" "is_a?" "lib" "macro" "module" "next"
"nil" "nil?" "of" "offsetof" "out" "pointerof" "private" "protected" "require"
"rescue" "responds_to?" "return" "select" "self" "sizeof" "struct" "super"
"then" "true" "type" "typeof" "uninitialized" "union" "unless" "until" "verbatim"
"when" "while" "with" "yield")
(csharp-mode
"abstract" "add" "alias" "as" "base" "bool" "break" "byte" "case"
"catch" "char" "checked" "class" "const" "continue" "decimal" "default"
@@ -95,6 +105,29 @@
"super" "switch" "synchronized" "template" "this" "throw" "true" "try"
"typedef" "typeid" "typeof" "ubyte" "ucent" "uint" "ulong" "union"
"unittest" "ushort" "version" "void" "volatile" "wchar" "while" "with")
(elixir-mode
;; from https://hexdocs.pm/elixir/Kernel.html
"__CALLER__" "__DIR__" "__ENV__" "__MODULE__" "__STACKTRACE__"
"__aliases__" "__block__" "abs" "alias" "alias!" "and" "apply"
"binary_part" "binary_slice" "binding" "bit_size" "byte_size" "case" "ceil"
"cond" "dbg" "def" "defdelegate" "defexception" "defguard" "defguardp"
"defimpl" "defmacro" "defmacrop" "defmodule" "defoverridable" "defp"
"defprotocol" "defstruct" "destructure" "div" "elem" "exit" "floor" "fn"
"for" "function_exported?" "get_and_update_in" "get_in" "hd" "if" "import"
"in" "inspect" "is_atom" "is_binary" "is_bitstring" "is_boolean"
"is_exception" "is_float" "is_function" "is_integer" "is_list" "is_map"
"is_map_key" "is_nil" "is_number" "is_pid" "is_port" "is_reference"
"is_struct" "is_tuple" "length" "macro_exported?" "make_ref" "map_size"
"match?" "max" "min" "node" "not" "or" "pop_in" "put_elem" "put_in" "quote"
"raise" "receive" "rem" "require" "reraise" "round" "self" "send" "spawn"
"spawn_link" "spawn_monitor" "struct" "struct!" "super" "tap" "then"
"throw" "tl" "to_charlist" "to_string" "trunc" "try" "tuple_size" "unless"
"unquote" "unquote_splicing" "update_in" "use" "var!" "with")
(erlang-mode
;; from https://www.erlang.org/docs/20/reference_manual/introduction.html#id63536
"after" "and" "andalso" "band" "begin" "bnot" "bor" "bsl" "bsr" "bxor"
"case" "catch" "cond" "div" "end" "fun" "if" "let" "not" "of" "or" "orelse"
"receive" "rem" "try" "when" "xor")
(f90-mode .
;; from f90.el
;; ".AND." ".GE." ".GT." ".LT." ".LE." ".NE." ".OR." ".TRUE." ".FALSE."
@@ -193,6 +226,14 @@
;; https://www.lua.org/manual/5.3/manual.html
"and" "break" "do" "else" "elseif" "end" "false" "for" "function" "goto" "if"
"in" "local" "nil" "not" "or" "repeat" "return" "then" "true" "until" "while")
(nim-mode
;; https://nim-lang.org/docs/manual.html#lexical-analysis-identifiers-amp-keywords
"addr" "and" "as" "asm" "bind" "block" "break" "case" "cast" "concept" "const" "continue"
"converter" "defer" "discard" "distinct" "div" "do" "elif" "else" "end" "enum" "except"
"export" "finally" "for" "from" "func" "if" "import" "in" "include" "interface" "is" "isnot"
"iterator" "let" "macro" "method" "mixin" "mod" "nil" "not" "notin" "object" "of" "or" "out"
"proc" "ptr" "raise" "ref" "return" "shl" "shr" "static" "template" "try" "tuple" "type"
"using" "var" "when" "while" "xor" "yield")
(objc-mode
"@catch" "@class" "@encode" "@end" "@finally" "@implementation"
"@interface" "@private" "@protected" "@protocol" "@public"
@@ -231,17 +272,24 @@
"ucfirst" "umask" "undef" "unless" "unlink" "unpack" "unshift" "untie"
"until" "use" "utime" "values" "vec" "wait" "waitpid"
"wantarray" "warn" "while" "write" "x" "xor" "y")
(php-mode
(php-mode ;; https://www.php.net/manual/reserved.php
"Closure" "Error" "Exception" "Generator" "Throwable"
"__CLASS__" "__DIR__" "__FILE__" "__FUNCTION__" "__LINE__" "__METHOD__"
"__NAMESPACE__" "_once" "abstract" "and" "array" "as" "break" "case"
"catch" "cfunction" "class" "clone" "const" "continue" "declare"
"default" "die" "do" "echo" "else" "elseif" "empty" "enddeclare"
"endfor" "endforeach" "endif" "endswitch" "endwhile" "eval" "exception"
"exit" "extends" "final" "for" "foreach" "function" "global"
"goto" "if" "implements" "include" "instanceof" "interface"
"isset" "list" "namespace" "new" "old_function" "or" "php_user_filter"
"print" "private" "protected" "public" "require" "require_once" "return"
"static" "switch" "this" "throw" "try" "unset" "use" "var" "while" "xor")
"__NAMESPACE__" "__TRAIT__"
"abstract" "and" "array" "as" "bool" "break" "callable" "case" "catch"
"class" "clone" "const" "continue" "declare" "default" "die" "do" "echo"
"else" "elseif" "empty" "enddeclare" "endfor" "endforeach" "endif"
"endswitch" "endwhile" "enum" "eval" "exit" "extends" "false" "final" "finally"
"float" "fn" "for" "foreach" "function" "global" "goto" "if"
"implements" "include" "include_once" "instanceof" "insteadof" "interface"
"isset" "iterable" "list" "match" "namespace" "new" "null" "object" "or"
"print" "private" "protected" "public" "readonly" "require" "require_once"
"return" "self" "static" "string" "switch" "this" "throw" "trait" "true"
"try" "unset" "use" "var" "void" "while" "xor" "yield" "yield from")
(purescript-mode ;; purescript-font-lock.el
"ado" "case" "class" "data" "default" "deriving" "do" "else" "if" "import"
"in" "infix" "infixl" "infixr" "instance" "let" "module" "newtype" "of"
"then" "type" "where")
(python-mode
;; https://docs.python.org/3/reference/lexical_analysis.html#keywords
"False" "None" "True" "and" "as" "assert" "break" "class" "continue" "def"
@@ -261,6 +309,68 @@
"false" "fn" "for" "if" "impl" "in" "let" "loop" "macro" "match" "mod"
"move" "mut" "pub" "ref" "return" "self" "static" "struct" "super"
"trait" "true" "type" "unsafe" "use" "where" "while")
; Extract from R7RS-small Tex: https://small.r7rs.org/
(scheme-mode
"abs" "acos" "angle" "append" "apply" "asin" "assoc" "assq" "assv"
"atan" "binary-port?" "body" "boolean=?" "boolean?" "bytevector"
"bytevector-append" "bytevector-copy" "bytevector-copy!"
"bytevector-length" "bytevector-u8-ref" "bytevector-u8-set!"
"bytevector?" "caaaar" "caaadr" "caaar" "caadar" "caaddr" "caadr"
"caar" "cadaar" "cadadr" "cadar" "caddar" "cadddr" "caddr" "cadr"
"call-with-port" "call-with-values" "car" "car-internal" "cdaaar"
"cdaadr" "cdaar" "cdadar" "cdaddr" "cdadr" "cdar" "cddaar" "cddadr"
"cddar" "cdddar" "cddddr" "cdddr" "cddr" "cdr" "ceiling"
"char->integer" "char-alphabetic?" "char-ci<=?" "char-ci<?"
"char-ci=?" "char-ci>=?" "char-ci>?" "char-downcase" "char-foldcase"
"char-lower-case?" "char-numeric?" "char-ready?" "char-upcase"
"char-upper-case?" "char-whitespace?" "char<=?" "char<?" "char=?"
"char>=?" "char>?" "char?" "close-input-port" "close-output-port"
"close-port" "command-line" "complex?" "cons" "cos"
"current-error-port" "current-input-port" "current-jiffy"
"current-output-port" "current-second" "delete-file" "denominator"
"digit-value" "display" "dynamic-wind" "emergency-exit" "environment"
"eof-object" "eof-object?" "eq?" "equal?" "eqv?" "error"
"error-object-irritants" "error-object-message" "error-object?" "eval"
"even?" "exact" "exact-integer-sqrt" "exact-integer?" "exact?" "exit"
"exp" "expt" "features" "file-error?" "file-exists?" "finite?" "floor"
"floor-quotient" "floor-remainder" "floor/" "flush-output-port" "gcd"
"get-environment-variable" "get-environment-variables"
"get-output-bytevector" "get-output-string" "imag-part" "inexact"
"inexact?" "infinite?" "input-port-open?" "input-port?"
"integer->char" "integer?" "interaction-environment"
"jiffies-per-second" "lcm" "length" "list" "list->string"
"list->vector" "list-copy" "list-ref" "list-set!" "list-tail" "list?"
"load" "log" "magnitude" "make-bytevector" "make-list"
"make-parameter" "make-polar" "make-promise" "make-rectangular"
"make-string" "make-vector" "max" "member" "memq" "memv" "min"
"modulo" "nan?" "negative?" "newline" "nil" "not" "null-environment"
"null?" "number->string" "number?" "numerator" "odd?"
"open-binary-input-file" "open-binary-output-file"
"open-input-bytevector" "open-input-file" "open-input-string"
"open-output-bytevector" "open-output-file" "open-output-string"
"output-port-open?" "output-port?" "pair?" "peek-char" "peek-u8"
"port?" "positive?" "procedure?" "promise?" "quasiquote" "quote"
"quotient" "raise" "raise-continuable" "rational?" "rationalize"
"read" "read-bytevector" "read-bytevector!" "read-char" "read-error?"
"read-line" "read-string" "read-u8" "real-part" "real?" "remainder"
"reverse" "round" "scheme-report-environment" "set!" "set-car!"
"set-cdr!" "setcar" "sin" "sqrt" "square" "string" "string->list"
"string->number" "string->symbol" "string->utf" "string->vector"
"string-append" "string-ci<=?" "string-ci<?" "string-ci=?"
"string-ci>=?" "string-ci>?" "string-copy" "string-copy!"
"string-downcase" "string-fill!" "string-foldcase" "string-for-each"
"string-length" "string-map" "string-ref" "string-set!"
"string-upcase" "string<=?" "string<?" "string=?" "string>=?"
"string>?" "string?" "substring" "symbol->string" "symbol=?" "symbol?"
"tan" "textual-port?" "truncate" "truncate-quotient"
"truncate-remainder" "truncate/" "u8-ready?" "unquote"
"unquote-splicing" "utf->string" "values" "vector" "vector->list"
"vector->string" "vector-append" "vector-copy" "vector-copy!"
"vector-fill!" "vector-for-each" "vector-length" "vector-map"
"vector-ref" "vector-set!" "vector?" "with-exception-handler"
"with-input-from-file" "with-output-to-file" "write"
"write-bytevector" "write-char" "write-shared" "write-simple"
"write-string" "write-u8" "zero?")
(scala-mode
"abstract" "case" "catch" "class" "def" "do" "else" "extends" "false"
"final" "finally" "for" "forSome" "if" "implicit" "import" "lazy" "match"
@@ -303,6 +413,7 @@
(cperl-mode . perl-mode)
(jde-mode . java-mode)
(ess-julia-mode . julia-mode)
(phps-mode . php-mode)
(enh-ruby-mode . ruby-mode))
"Alist mapping major-modes to sorted keywords for `company-keywords'.")

2
lisp/company/company-nxml.el
View File

@@ -1,6 +1,6 @@
;;; company-nxml.el --- company-mode completion backend for nxml-mode
;; Copyright (C) 2009-2011, 2013, 2018 Free Software Foundation, Inc.
;; Copyright (C) 2009-2011, 2013-2015, 2017-2018 Free Software Foundation, Inc.
;; Author: Nikolaj Schumacher

4
lisp/company/company-oddmuse.el
View File

@@ -1,6 +1,6 @@
;;; company-oddmuse.el --- company-mode completion backend for oddmuse-mode
;; Copyright (C) 2009-2011, 2014 Free Software Foundation, Inc.
;; Copyright (C) 2009-2011, 2013-2016, 2022 Free Software Foundation, Inc.
;; Author: Nikolaj Schumacher
@@ -48,7 +48,7 @@
(interactive (company-begin-backend 'company-oddmuse))
(prefix (let ((case-fold-search nil))
(and (memq major-mode '(oddmuse-mode yaoddmuse-mode))
(looking-back company-oddmuse-link-regexp (point-at-bol))
(looking-back company-oddmuse-link-regexp (line-beginning-position))
(or (match-string 1)
(match-string 2)))))
(candidates (all-completions arg (company-oddmuse-get-page-table)))))

6
lisp/company/company-pkg.el
View File

@@ -1,8 +1,6 @@
(define-package "company" "20220103.351" "Modular text completion framework"
(define-package "company" "20221206.2122" "Modular text completion framework"
'((emacs "25.1"))
:commit "6eeaf46b869552b7cb70cab7d4590120c64cc175" :authors
'(("Nikolaj Schumacher"))
:maintainer
:commit "6884e3ad717419b4a64a5fab08c8cb9bd20a0b27" :maintainer
'("Dmitry Gutov" . "dgutov@yandex.ru")
:keywords
'("abbrev" "convenience" "matching")

2
lisp/company/company-semantic.el
View File

@@ -1,6 +1,6 @@
;;; company-semantic.el --- company-mode completion backend using Semantic
;; Copyright (C) 2009-2011, 2013-2016 Free Software Foundation, Inc.
;; Copyright (C) 2009-2011, 2013-2018 Free Software Foundation, Inc.
;; Author: Nikolaj Schumacher

2
lisp/company/company-template.el
View File

@@ -1,6 +1,6 @@
;;; company-template.el --- utility library for template expansion
;; Copyright (C) 2009, 2010, 2014-2017 Free Software Foundation, Inc.
;; Copyright (C) 2009-2010, 2013-2017, 2019 Free Software Foundation, Inc.
;; Author: Nikolaj Schumacher

2
lisp/company/company-tempo.el
View File

@@ -1,6 +1,6 @@
;;; company-tempo.el --- company-mode completion backend for tempo
;; Copyright (C) 2009-2011, 2015 Free Software Foundation, Inc.
;; Copyright (C) 2009-2011, 2013-2016 Free Software Foundation, Inc.
;; Author: Nikolaj Schumacher

4
lisp/company/company-yasnippet.el
View File

@@ -1,6 +1,6 @@
;;; company-yasnippet.el --- company-mode completion backend for Yasnippet
;; Copyright (C) 2014, 2015, 2020 Free Software Foundation, Inc.
;; Copyright (C) 2014-2015, 2020-2021 Free Software Foundation, Inc.
;; Author: Dmitry Gutov
@@ -116,9 +116,11 @@ It has to accept one argument: the snippet's name.")
(let ((template (get-text-property 0 'yas-template arg))
(mode major-mode)
(file-name (buffer-file-name)))
(defvar yas-prompt-functions)
(with-current-buffer (company-doc-buffer)
(let ((buffer-file-name file-name))
(yas-minor-mode 1)
(setq-local yas-prompt-functions '(yas-no-prompt))
(condition-case error
(yas-expand-snippet (yas--template-content template))
(error

146
lisp/company/company.el
View File

@@ -1,6 +1,6 @@
;;; company.el --- Modular text completion framework -*- lexical-binding: t -*-
;; Copyright (C) 2009-2021 Free Software Foundation, Inc.
;; Copyright (C) 2009-2022 Free Software Foundation, Inc.
;; Author: Nikolaj Schumacher
;; Maintainer: Dmitry Gutov <dgutov@yandex.ru>
@@ -513,7 +513,7 @@ without duplicates."
(company-sort-by-backend-importance))
(const :tag "Prefer case sensitive prefix"
(company-sort-prefer-same-case-prefix))
(repeat :tag "User defined" (function))))
(repeat :tag "User defined" function)))
(defcustom company-completion-started-hook nil
"Hook run when company starts completing.
@@ -566,45 +566,61 @@ doesn't match anything or finish it manually, e.g. with RET."
This can be a function do determine if a match is required.
This can be overridden by the backend, if it returns t or `never' to
`require-match'. `company-auto-commit' also takes precedence over this."
`require-match'. `company-insertion-on-trigger' also takes precedence over
this."
:type '(choice (const :tag "Off" nil)
(function :tag "Predicate function")
(const :tag "On, if user interaction took place"
'company-explicit-action-p)
company-explicit-action-p)
(const :tag "On" t)))
(define-obsolete-variable-alias
'company-auto-complete
'company-auto-commit
'company-insertion-on-trigger
"0.9.14")
(defcustom company-auto-commit nil
"Determines whether to auto-commit.
If this is enabled, all characters from `company-auto-commit-chars'
trigger insertion of the selected completion candidate.
This can also be a function."
(define-obsolete-variable-alias
'company-auto-commit
'company-insertion-on-trigger
"0.9.14")
(defcustom company-insertion-on-trigger nil
"If enabled, allow triggering insertion of the selected candidate.
This can also be a predicate function, for example,
`company-explicit-action-p'.
See `company-insertion-triggers' for more details on how to define
triggers."
:type '(choice (const :tag "Off" nil)
(function :tag "Predicate function")
(const :tag "On, if user interaction took place"
'company-explicit-action-p)
company-explicit-action-p)
(const :tag "On" t))
:package-version '(company . "0.9.14"))
(define-obsolete-variable-alias
'company-auto-complete-chars
'company-auto-commit-chars
'company-insertion-triggers
"0.9.14")
(defcustom company-auto-commit-chars '(?\ ?\) ?.)
"Determines which characters trigger auto-commit.
See `company-auto-commit'. If this is a string, each character in it
triggers auto-commit. If it is a list of syntax description characters (see
`modify-syntax-entry'), characters with any of those syntaxes do that.
(define-obsolete-variable-alias
'company-auto-commit-chars
'company-insertion-triggers
"0.9.14")
This can also be a function, which is called with the new input and should
return non-nil if company should auto-commit.
(defcustom company-insertion-triggers '(?\ ?\) ?.)
"Determine triggers for `company-insertion-on-trigger'.
A character that is part of a valid completion never triggers auto-commit."
If this is a string, then each character in it can trigger insertion of the
selected candidate. If it is a list of syntax description characters (see
`modify-syntax-entry'), then characters with any of those syntaxes can act
as triggers.
This can also be a function, which is called with the new input. To
trigger insertion, the function should return a non-nil value.
Note that a character that is part of a valid completion never triggers
insertion."
:type '(choice (string :tag "Characters")
(set :tag "Syntax"
(const :tag "Whitespace" ?\ )
@@ -654,7 +670,7 @@ pre-defined list. See `company-idle-delay'.
Alternatively, any command with a non-nil `company-begin' property is
treated as if it was on this list."
:type '(choice (const :tag "Any command" t)
(const :tag "Self insert command" '(self-insert-command))
(const :tag "Self insert command" (self-insert-command))
(repeat :tag "Commands" function))
:package-version '(company . "0.8.4"))
@@ -1059,7 +1075,7 @@ If EXPRESSION is non-nil, return the match string for the respective
parenthesized expression in REGEXP.
Matching is limited to the current line."
(let ((inhibit-field-text-motion t))
(company-grab regexp expression (point-at-bol))))
(company-grab regexp expression (line-beginning-position))))
(defun company-grab-symbol ()
"If point is at the end of a symbol, return it.
@@ -1324,7 +1340,15 @@ can retrieve meta-data for them."
(and (symbolp this-command)
(string-match-p "\\`company-" (symbol-name this-command)))))))
(defvar company-auto-update-doc nil
"If non-nil, update the documentation buffer on each selection change.
To toggle the value of this variable, call `company-show-doc-buffer' with a
prefix argument.")
(defun company-call-frontends (command)
(when (and company-auto-update-doc
(memq command '(update show)))
(company-show-doc-buffer))
(cl-loop for frontend in company-frontends collect
(condition-case-unless-debug err
(funcall frontend command)
@@ -1673,14 +1697,14 @@ fields without issue.
When BG is omitted and `company-text-icons-add-background' is non-nil, a BG
color is generated using a gradient between the active tooltip color and
the FG color."
:type 'list)
:type '(repeat sexp))
(defcustom company-text-face-extra-attributes '(:weight bold)
"Additional attributes to add to text/dot icons faces.
If non-nil, an anonymous face is generated.
Affects `company-text-icons-margin' and `company-dot-icons-margin'."
:type 'list)
:type '(plist :tag "Face property list"))
(defcustom company-text-icons-format " %s "
"Format string for printing the text icons."
@@ -1771,7 +1795,7 @@ PROPERTY return nil."
(if (and (display-graphic-p)
(image-type-available-p 'svg))
(cl-case (frame-parameter nil 'background-mode)
('light (company-vscode-light-icons-margin candidate selected))
(light (company-vscode-light-icons-margin candidate selected))
(t (company-vscode-dark-icons-margin candidate selected)))
(company-text-icons-margin candidate selected)))
@@ -1954,18 +1978,20 @@ prefix match (same case) will be prioritized."
(funcall company-require-match)
(eq company-require-match t))))))
(defun company-auto-commit-p (input)
"Return non-nil if INPUT should trigger auto-commit."
(and (if (functionp company-auto-commit)
(funcall company-auto-commit)
company-auto-commit)
(if (functionp company-auto-commit-chars)
(funcall company-auto-commit-chars input)
(if (consp company-auto-commit-chars)
(defun company-insertion-on-trigger-p (input)
"Return non-nil if INPUT should trigger insertion.
For more details see `company-insertion-on-trigger' and
`company-insertion-triggers'."
(and (if (functionp company-insertion-on-trigger)
(funcall company-insertion-on-trigger)
company-insertion-on-trigger)
(if (functionp company-insertion-triggers)
(funcall company-insertion-triggers input)
(if (consp company-insertion-triggers)
(memq (char-syntax (string-to-char input))
company-auto-commit-chars)
company-insertion-triggers)
(string-match (regexp-quote (substring input 0 1))
company-auto-commit-chars)))))
company-insertion-triggers)))))
(defun company--incremental-p ()
(and (> (point) company-point)
@@ -2030,8 +2056,8 @@ prefix match (same case) will be prioritized."
(company-update-candidates c)
c)
((and (characterp last-command-event)
(company-auto-commit-p (string last-command-event)))
;; auto-commit
(company-insertion-on-trigger-p (string last-command-event)))
;; Insertion on trigger.
(save-excursion
(goto-char company-point)
(company-complete-selection)
@@ -2509,7 +2535,8 @@ and invoke the normal binding.
With ARG, move by that many elements."
(interactive "p")
(if (> company-candidates-length 1)
(if (or (not company-selection)
(> company-candidates-length 1))
(company-select-next arg)
(company-abort)
(company--unread-this-command-keys)))
@@ -2609,6 +2636,18 @@ With ARG, move by that many elements."
(current-prefix-arg arg))
(call-interactively 'company-select-next))))))
(defun company-complete-common-or-show-delayed-tooltip ()
"Insert the common part of all candidates, or show a tooltip."
(interactive)
(when (company-manual-begin)
(let ((tick (buffer-chars-modified-tick)))
(call-interactively 'company-complete-common)
(when (eq tick (buffer-chars-modified-tick))
(let ((company-tooltip-idle-delay 0.0))
(company-complete)
(and company-candidates
(company-call-frontends 'post-command)))))))
(defun company-indent-or-complete-common (arg)
"Indent the current line or region, or complete the common part."
(interactive "P")
@@ -2790,22 +2829,37 @@ from the candidates list.")
unread-command-events))
(clear-this-command-keys t)))
(defun company-show-doc-buffer ()
"Temporarily show the documentation buffer for the selection."
(interactive)
(defun company--show-doc-buffer ()
"Show the documentation buffer for the selection."
(let ((other-window-scroll-buffer)
(selection (or company-selection 0)))
(company--electric-do
(let* ((selected (nth selection company-candidates))
(doc-buffer (or (company-call-backend 'doc-buffer selected)
(user-error "No documentation available")))
(if company-auto-update-doc
(company-doc-buffer
(format "%s: No documentation available"
selected))
(user-error "No documentation available"))))
start)
(when (consp doc-buffer)
(setq start (cdr doc-buffer)
doc-buffer (car doc-buffer)))
(setq other-window-scroll-buffer (get-buffer doc-buffer))
(let ((win (display-buffer doc-buffer t)))
(set-window-start win (if start start (point-min))))))))
(set-window-start win (if start start (point-min)))))))
(defun company-show-doc-buffer (&optional toggle-auto-update)
"Show the documentation buffer for the selection.
With a prefix argument TOGGLE-AUTO-UPDATE, toggle the value of
`company-auto-update-doc'. When `company-auto-update-doc' is non-nil,
automatically show the documentation buffer for each selection."
(interactive "P")
(when toggle-auto-update
(setq company-auto-update-doc (not company-auto-update-doc)))
(if company-auto-update-doc
(company--show-doc-buffer)
(company--electric-do
(company--show-doc-buffer))))
(put 'company-show-doc-buffer 'company-keep t)
(defun company-show-location ()
@@ -2833,7 +2887,7 @@ from the candidates list.")
(defvar-local company-callback nil)
(defun company-remove-callback (&optional ignored)
(defun company-remove-callback (&optional _ignored)
(remove-hook 'company-completion-finished-hook company-callback t)
(remove-hook 'company-completion-cancelled-hook 'company-remove-callback t)
(remove-hook 'company-completion-finished-hook 'company-remove-callback t))
@@ -2867,7 +2921,7 @@ successfully completes the input.
Example: \(company-begin-with \\='\(\"foo\" \"foobar\" \"foobarbaz\"\)\)"
(let ((begin-marker (copy-marker (point) t)))
(company-begin-backend
(lambda (command &optional arg &rest ignored)
(lambda (command &optional arg &rest _ignored)
(pcase command
(`prefix
(when (equal (point) (marker-position begin-marker))

268
lisp/company/company.info
View File

@@ -1,10 +1,9 @@
This is company.info, produced by makeinfo version 6.7 from
This is company.info, produced by makeinfo version 7.0.1 from
company.texi.
This user manual is for Company version 0.9.14snapshot
(28 December 2021).
This user manual is for Company version 0.9.14snapshot (12 August 2022).
Copyright © 2021 Free Software Foundation, Inc.
Copyright © 2021-2022 Free Software Foundation, Inc.
Permission is granted to copy, distribute and/or modify this
document under the terms of the GNU Free Documentation License,
@@ -27,10 +26,9 @@ The goal of this document is to lay out the foundational knowledge of
the package, so that the readers of the manual could competently start
adapting Company to their needs and preferences.
This user manual is for Company version 0.9.14snapshot
(28 December 2021).
This user manual is for Company version 0.9.14snapshot (12 August 2022).
Copyright © 2021 Free Software Foundation, Inc.
Copyright © 2021-2022 Free Software Foundation, Inc.
Permission is granted to copy, distribute and/or modify this
document under the terms of the GNU Free Documentation License,
@@ -266,9 +264,12 @@ commands of the out-of-the-box Company.
Cancel _company-mode_ activity (‘company-abort’).
‘C-h’
‘<f1>’
‘<F1>’
Display a buffer with the documentation for the selected candidate
(‘company-show-doc-buffer’).
(‘company-show-doc-buffer’). With a prefix argument (‘C-u C-h’,
‘C-u <F1>’), this command toggles between temporary showing the
documentation and keeping the documentation buffer up-to-date
whenever the selection changes.
‘C-w’
Display a buffer with the definition of the selected candidate
@@ -406,23 +407,24 @@ core settings that influence the overall behavior of the _company-mode_.
enabled _company-mode_ in the mode line. The default value is
‘company’.
-- User Option: company-auto-commit
-- User Option: company-insertion-on-trigger
One more pair of the user options may instruct Company to complete
with the selected candidate by typing one of the
‘company-auto-commit-chars’ (1). The user option
‘company-auto-commit’ can be enabled or disabled by setting its
value to one of: ‘nil’, ‘t’, or a predicate function name. *note
Predicate: (eintr)Wrong Type of Argument.
‘company-insertion-triggers’. The user option
‘company-insertion-on-trigger’ can be enabled or disabled by
setting its value to one of: ‘nil’, ‘t’, or a predicate function
name. *note Predicate: (eintr)Wrong Type of Argument.
-- User Option: company-auto-commit-chars
This option acts only when ‘company-auto-commit’ is enabled. The
value can be one of: a string of characters, a list of syntax
description characters (*note (elisp)Syntax Class Table::), or a
predicate function. By default, ‘company-auto-commit-chars’ is set
to the list of the syntax characters: ‘(?\ ?\) ?.)’, which
-- User Option: company-insertion-triggers
This option has an effect only when ‘company-insertion-on-trigger’
is enabled. The value can be one of: a string of characters, a
list of syntax description characters (*note (elisp)Syntax Class
Table::), or a predicate function. By default, this user option is
set to the list of the syntax characters: ‘(?\ ?\) ?.)’, which
translates to the whitespaces, close parenthesis, and punctuation.
The particular convenience of this user option values is they do
not act as triggers when they are part of valid completion.
It is safe to configure the value to a character that can
potentially be part of a valid completion; in this case, Company
does not treat such characters as triggers.
Hooks
-----
@@ -437,17 +439,6 @@ Company exposes the following life-cycle hooks:
-- User Option: company-after-completion-hook
---------- Footnotes ----------
(1) The options ‘company-auto-commit’ and ‘company-auto-commit-chars’
used to be called ‘company-auto-complete’ and
‘company-auto-complete-chars’ respectively, which was in more accordance
with the terminology given in this manual. But the resulting
combination of the words ‘auto-complete’ present in those names made it
seem the role of these user options was to configure Company’s
auto-start behavior. Hence, it was chosen to rename the options to,
hopefully, less confusing names.

File: company.info, Node: Frontends, Next: Backends, Prev: Customization, Up: Top
@@ -1342,7 +1333,7 @@ Key Index
* C-p: Usage Basics. (line 12)
* C-p <1>: Commands. (line 16)
* C-s: Candidates Search. (line 6)
* C-w: Commands. (line 39)
* C-w: Commands. (line 41)
* M-<digit>: Quick Access a Candidate.
(line 6)
* RET: Usage Basics. (line 15)
@@ -1360,8 +1351,6 @@ Variable Index
* Menu:
* company-after-completion-hook: Configuration File. (line 94)
* company-auto-commit: Configuration File. (line 64)
* company-auto-commit-chars: Configuration File. (line 72)
* company-backends: Backends. (line 12)
* company-backends <1>: Backends Usage Basics.
(line 6)
@@ -1374,18 +1363,20 @@ Variable Index
* company-dabbrev-ignore-case: Text Completion. (line 47)
* company-dabbrev-minimum-length: Text Completion. (line 13)
* company-dabbrev-other-buffers: Text Completion. (line 23)
* company-dot-icons-format: Tooltip Frontends. (line 179)
* company-dot-icons-format: Tooltip Frontends. (line 176)
* company-echo-truncate-lines: Echo Frontends. (line 33)
* company-files-chop-trailing-slash: File Name Completion.
(line 19)
* company-files-exclusions: File Name Completion.
(line 12)
* company-format-margin-function: Tooltip Frontends. (line 153)
* company-format-margin-function: Tooltip Frontends. (line 151)
* company-frontends: Frontends. (line 6)
* company-global-modes: Configuration File. (line 31)
* company-icon-margin: Tooltip Frontends. (line 164)
* company-icon-size: Tooltip Frontends. (line 164)
* company-icon-margin: Tooltip Frontends. (line 162)
* company-icon-size: Tooltip Frontends. (line 162)
* company-idle-delay: Configuration File. (line 17)
* company-insertion-on-trigger: Configuration File. (line 64)
* company-insertion-triggers: Configuration File. (line 72)
* company-ispell-dictionary: Text Completion. (line 84)
* company-lighter-base: Configuration File. (line 59)
* company-minimum-prefix-length: Configuration File. (line 9)
@@ -1396,21 +1387,21 @@ Variable Index
* company-search-regexp-function: Candidates Search. (line 13)
* company-selection-wrap-around: Configuration File. (line 43)
* company-show-quick-access: Quick Access a Candidate.
(line 14)
* company-text-face-extra-attributes: Tooltip Frontends. (line 192)
* company-text-icons-add-background: Tooltip Frontends. (line 200)
* company-text-icons-format: Tooltip Frontends. (line 171)
* company-text-icons-mapping: Tooltip Frontends. (line 188)
* company-tooltip-align-annotations: Tooltip Frontends. (line 52)
* company-tooltip-flip-when-above: Tooltip Frontends. (line 99)
* company-tooltip-idle-delay: Tooltip Frontends. (line 22)
* company-tooltip-limit: Tooltip Frontends. (line 64)
* company-tooltip-margin: Tooltip Frontends. (line 133)
* company-tooltip-maximum-width: Tooltip Frontends. (line 126)
* company-tooltip-minimum: Tooltip Frontends. (line 84)
* company-tooltip-minimum-width: Tooltip Frontends. (line 111)
* company-tooltip-offset-display: Tooltip Frontends. (line 74)
* company-tooltip-width-grow-only: Tooltip Frontends. (line 121)
(line 12)
* company-text-face-extra-attributes: Tooltip Frontends. (line 189)
* company-text-icons-add-background: Tooltip Frontends. (line 197)
* company-text-icons-format: Tooltip Frontends. (line 169)
* company-text-icons-mapping: Tooltip Frontends. (line 185)
* company-tooltip-align-annotations: Tooltip Frontends. (line 51)
* company-tooltip-flip-when-above: Tooltip Frontends. (line 98)
* company-tooltip-idle-delay: Tooltip Frontends. (line 21)
* company-tooltip-limit: Tooltip Frontends. (line 63)
* company-tooltip-margin: Tooltip Frontends. (line 132)
* company-tooltip-maximum-width: Tooltip Frontends. (line 125)
* company-tooltip-minimum: Tooltip Frontends. (line 83)
* company-tooltip-minimum-width: Tooltip Frontends. (line 110)
* company-tooltip-offset-display: Tooltip Frontends. (line 73)
* company-tooltip-width-grow-only: Tooltip Frontends. (line 120)
* company-transformers: Candidates Post-Processing.
(line 6)
@@ -1426,7 +1417,7 @@ Function Index
* company-abbrev: Template Expansion. (line 6)
* company-abort: Commands. (line 30)
* company-begin-backend: Backends Usage Basics.
(line 23)
(line 22)
* company-capf: Code Completion. (line 6)
* company-clang: Code Completion. (line 36)
* company-complete: Usage Basics. (line 10)
@@ -1434,11 +1425,11 @@ Function Index
* company-complete-selection: Commands. (line 21)
* company-dabbrev: Text Completion. (line 6)
* company-dabbrev-code: Code Completion. (line 25)
* company-detect-icons-margin: Tooltip Frontends. (line 209)
* company-detect-icons-margin: Tooltip Frontends. (line 206)
* company-diag: Backends Usage Basics.
(line 11)
* company-diag <1>: Troubleshooting. (line 6)
* company-dot-icons-margin: Tooltip Frontends. (line 178)
* company-dot-icons-margin: Tooltip Frontends. (line 175)
* company-echo-frontend: Echo Frontends. (line 21)
* company-echo-metadata-frontend: Echo Frontends. (line 9)
* company-echo-strip-common-frontend: Echo Frontends. (line 27)
@@ -1453,11 +1444,11 @@ Function Index
* company-preview-common-frontend: Preview Frontends. (line 21)
* company-preview-frontend: Preview Frontends. (line 17)
* company-preview-if-just-one-frontend: Preview Frontends. (line 10)
* company-pseudo-tooltip-frontend: Tooltip Frontends. (line 17)
* company-pseudo-tooltip-frontend: Tooltip Frontends. (line 16)
* company-pseudo-tooltip-unless-just-one-frontend: Tooltip Frontends.
(line 11)
(line 10)
* company-pseudo-tooltip-unless-just-one-frontend-with-delay: Tooltip Frontends.
(line 21)
(line 20)
* company-search-flex-regexp: Candidates Search. (line 26)
* company-search-words-in-any-order-regexp: Candidates Search.
(line 23)
@@ -1468,19 +1459,19 @@ Function Index
* company-select-previous-or-abort: Commands. (line 16)
* company-semantic: Code Completion. (line 41)
* company-show-doc-buffer: Commands. (line 34)
* company-show-location: Commands. (line 39)
* company-show-location: Commands. (line 41)
* company-sort-by-backend-importance: Candidates Post-Processing.
(line 28)
(line 27)
* company-sort-by-occurrence: Candidates Post-Processing.
(line 17)
* company-sort-prefer-same-case-prefix: Candidates Post-Processing.
(line 34)
(line 33)
* company-tempo: Template Expansion. (line 11)
* company-text-icons-margin: Tooltip Frontends. (line 170)
* company-text-icons-margin: Tooltip Frontends. (line 168)
* company-tng-frontend: Structure. (line 26)
* company-tng-mode: Structure. (line 26)
* company-vscode-dark-icons-margin: Tooltip Frontends. (line 162)
* company-vscode-light-icons-margin: Tooltip Frontends. (line 163)
* company-vscode-dark-icons-margin: Tooltip Frontends. (line 160)
* company-vscode-light-icons-margin: Tooltip Frontends. (line 161)
* company-yasnippet: Template Expansion. (line 16)
* global-company-mode: Initial Setup. (line 18)
@@ -1499,8 +1490,8 @@ Concept Index
* activate: Initial Setup. (line 8)
* active backend: Backends Usage Basics.
(line 11)
* active backend <1>: Troubleshooting. (line 15)
* annotation: Tooltip Frontends. (line 53)
* active backend <1>: Troubleshooting. (line 14)
* annotation: Tooltip Frontends. (line 52)
* auto-start: Initial Setup. (line 13)
* backend: Structure. (line 6)
* backend <1>: Structure. (line 10)
@@ -1508,7 +1499,7 @@ Concept Index
(line 11)
* backend <3>: Backends Usage Basics.
(line 14)
* backend <4>: Troubleshooting. (line 15)
* backend <4>: Troubleshooting. (line 14)
* backends: Backends. (line 6)
* backends <1>: Backends Usage Basics.
(line 6)
@@ -1516,7 +1507,7 @@ Concept Index
* backends <3>: Package Backends. (line 6)
* basics: Usage Basics. (line 6)
* bug: Troubleshooting. (line 6)
* bug <1>: Troubleshooting. (line 27)
* bug <1>: Troubleshooting. (line 25)
* bundled backends: Package Backends. (line 6)
* cancel: Usage Basics. (line 20)
* cancel <1>: Commands. (line 30)
@@ -1524,16 +1515,16 @@ Concept Index
* candidate <1>: Usage Basics. (line 12)
* candidate <2>: Usage Basics. (line 15)
* candidate <3>: Preview Frontends. (line 6)
* color: Tooltip Frontends. (line 219)
* color: Tooltip Frontends. (line 215)
* color <1>: Quick Access a Candidate.
(line 37)
(line 34)
* common part: Usage Basics. (line 17)
* common part <1>: Commands. (line 25)
* common part <2>: Preview Frontends. (line 6)
* company-echo: Echo Frontends. (line 6)
* company-preview: Preview Frontends. (line 6)
* company-tng: Structure. (line 26)
* company-tooltip: Tooltip Frontends. (line 219)
* company-tooltip: Tooltip Frontends. (line 215)
* company-tooltip-search: Candidates Search. (line 6)
* complete: Terminology. (line 6)
* complete <1>: Usage Basics. (line 12)
@@ -1549,29 +1540,29 @@ Concept Index
* configure <1>: Customization Interface.
(line 6)
* configure <2>: Configuration File. (line 6)
* configure <3>: Tooltip Frontends. (line 49)
* configure <4>: Tooltip Frontends. (line 219)
* configure <3>: Tooltip Frontends. (line 48)
* configure <4>: Tooltip Frontends. (line 215)
* configure <5>: Preview Frontends. (line 25)
* configure <6>: Echo Frontends. (line 38)
* configure <7>: Candidates Search. (line 30)
* configure <8>: Quick Access a Candidate.
(line 28)
(line 25)
* configure <9>: Quick Access a Candidate.
(line 37)
(line 34)
* custom: Customization. (line 6)
* custom <1>: Customization Interface.
(line 6)
* custom <2>: Configuration File. (line 6)
* custom <3>: Tooltip Frontends. (line 49)
* custom <4>: Tooltip Frontends. (line 219)
* custom <3>: Tooltip Frontends. (line 48)
* custom <4>: Tooltip Frontends. (line 215)
* custom <5>: Preview Frontends. (line 25)
* custom <6>: Echo Frontends. (line 38)
* custom <7>: Candidates Search. (line 30)
* custom <8>: Quick Access a Candidate.
(line 28)
(line 25)
* custom <9>: Quick Access a Candidate.
(line 37)
* definition: Commands. (line 39)
(line 34)
* definition: Commands. (line 41)
* distribution: Installation. (line 6)
* doc: Commands. (line 34)
* duplicate: Candidates Post-Processing.
@@ -1579,10 +1570,10 @@ Concept Index
* echo: Echo Frontends. (line 6)
* enable: Initial Setup. (line 8)
* error: Troubleshooting. (line 6)
* error <1>: Troubleshooting. (line 27)
* error <1>: Troubleshooting. (line 25)
* expansion: Template Expansion. (line 6)
* extensible: Structure. (line 6)
* face: Tooltip Frontends. (line 219)
* face: Tooltip Frontends. (line 215)
* face <1>: Preview Frontends. (line 6)
* face <2>: Preview Frontends. (line 25)
* face <3>: Echo Frontends. (line 6)
@@ -1591,35 +1582,35 @@ Concept Index
* face <6>: Candidates Search. (line 30)
* face <7>: Filter Candidates. (line 6)
* face <8>: Quick Access a Candidate.
(line 37)
(line 34)
* filter: Filter Candidates. (line 6)
* finish: Usage Basics. (line 20)
* finish <1>: Commands. (line 30)
* font: Tooltip Frontends. (line 219)
* font: Tooltip Frontends. (line 215)
* font <1>: Quick Access a Candidate.
(line 37)
(line 34)
* frontend: Structure. (line 6)
* frontend <1>: Structure. (line 10)
* frontends: Frontends. (line 6)
* grouped backends: Grouped Backends. (line 6)
* icon: Tooltip Frontends. (line 145)
* icon: Tooltip Frontends. (line 144)
* install: Installation. (line 6)
* interface: Tooltip Frontends. (line 49)
* interface <1>: Tooltip Frontends. (line 219)
* interface: Tooltip Frontends. (line 48)
* interface <1>: Tooltip Frontends. (line 215)
* interface <2>: Preview Frontends. (line 25)
* interface <3>: Echo Frontends. (line 38)
* interface <4>: Candidates Search. (line 30)
* interface <5>: Quick Access a Candidate.
(line 37)
(line 34)
* intro: Initial Setup. (line 6)
* issue: Troubleshooting. (line 6)
* issue tracker: Troubleshooting. (line 27)
* kind: Tooltip Frontends. (line 145)
* location: Commands. (line 39)
* issue tracker: Troubleshooting. (line 25)
* kind: Tooltip Frontends. (line 144)
* location: Commands. (line 41)
* manual: Initial Setup. (line 8)
* manual <1>: Usage Basics. (line 10)
* margin: Tooltip Frontends. (line 134)
* margin <1>: Tooltip Frontends. (line 154)
* margin: Tooltip Frontends. (line 133)
* margin <1>: Tooltip Frontends. (line 152)
* minor-mode: Initial Setup. (line 6)
* module: Structure. (line 6)
* module <1>: Structure. (line 10)
@@ -1651,7 +1642,7 @@ Concept Index
* Tab and Go: Structure. (line 26)
* template: Template Expansion. (line 6)
* third-party: Structure. (line 10)
* third-party <1>: Troubleshooting. (line 18)
* third-party <1>: Troubleshooting. (line 17)
* tooltip: Tooltip Frontends. (line 6)
* troubleshoot: Troubleshooting. (line 6)
* usage: Usage Basics. (line 6)
@@ -1659,48 +1650,45 @@ Concept Index

Tag Table:
Node: Top569
Node: Overview1994
Node: Terminology2402
Ref: Terminology-Footnote-13389
Node: Structure3595
Node: Getting Started5091
Node: Installation5369
Node: Initial Setup5752
Node: Usage Basics6598
Node: Commands7361
Ref: Commands-Footnote-19579
Node: Customization9746
Node: Customization Interface10218
Node: Configuration File10751
Ref: company-auto-commit14058
Ref: company-auto-commit-chars14480
Ref: Configuration File-Footnote-115387
Node: Frontends15901
Node: Tooltip Frontends16870
Ref: Tooltip Frontends-Footnote-127239
Node: Preview Frontends27476
Ref: Preview Frontends-Footnote-128732
Node: Echo Frontends28859
Node: Candidates Search30392
Node: Filter Candidates31726
Node: Quick Access a Candidate32506
Node: Backends34124
Node: Backends Usage Basics35222
Ref: Backends Usage Basics-Footnote-136437
Node: Grouped Backends36521
Node: Package Backends38150
Node: Code Completion39079
Node: Text Completion41448
Node: File Name Completion45882
Node: Template Expansion47430
Node: Candidates Post-Processing48149
Node: Troubleshooting49626
Node: Index51299
Node: Key Index51462
Node: Variable Index52961
Node: Function Index57011
Node: Concept Index61492
Node: Top574
Node: Overview2002
Node: Terminology2410
Ref: Terminology-Footnote-13397
Node: Structure3603
Node: Getting Started5099
Node: Installation5377
Node: Initial Setup5760
Node: Usage Basics6606
Node: Commands7369
Ref: Commands-Footnote-19804
Node: Customization9971
Node: Customization Interface10443
Node: Configuration File10976
Node: Frontends15642
Node: Tooltip Frontends16611
Ref: Tooltip Frontends-Footnote-126980
Node: Preview Frontends27217
Ref: Preview Frontends-Footnote-128473
Node: Echo Frontends28600
Node: Candidates Search30133
Node: Filter Candidates31467
Node: Quick Access a Candidate32247
Node: Backends33865
Node: Backends Usage Basics34963
Ref: Backends Usage Basics-Footnote-136178
Node: Grouped Backends36262
Node: Package Backends37891
Node: Code Completion38820
Node: Text Completion41189
Node: File Name Completion45623
Node: Template Expansion47171
Node: Candidates Post-Processing47890
Node: Troubleshooting49367
Node: Index51040
Node: Key Index51203
Node: Variable Index52702
Node: Function Index56752
Node: Concept Index61233

End Tag Table

BIN
lisp/company/images/small/echo-meta.png Executable file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 42 KiB

BIN
lisp/company/images/small/echo-qa.png Executable file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 18 KiB

BIN
lisp/company/images/small/echo-strip-qa.png Executable file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 21 KiB

BIN
lisp/company/images/small/echo-strip.png Executable file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 15 KiB

BIN
lisp/company/images/small/echo.png Executable file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 16 KiB

BIN
lisp/company/images/small/preview-dark.png Executable file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 5.0 KiB

BIN
lisp/company/images/small/preview-light.png Executable file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 5.4 KiB

BIN
lisp/company/images/small/tooltip-annotations.png Executable file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 29 KiB

BIN
lisp/company/images/small/tooltip-faces-light.png Executable file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 14 KiB

BIN
lisp/company/images/small/tooltip-filter.png Executable file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 29 KiB

BIN
lisp/company/images/small/tooltip-flip.png Executable file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 33 KiB

BIN
lisp/company/images/small/tooltip-icon-bg.png Executable file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 25 KiB

BIN
lisp/company/images/small/tooltip-icon-face.png Executable file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 28 KiB

BIN
lisp/company/images/small/tooltip-icons-dot.png Executable file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 44 KiB

BIN
lisp/company/images/small/tooltip-icons-text.png Executable file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 41 KiB

BIN
lisp/company/images/small/tooltip-icons-vscode.png Executable file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 46 KiB

BIN
lisp/company/images/small/tooltip-limit.png Executable file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 21 KiB

BIN
lisp/company/images/small/tooltip-margin.png Executable file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 29 KiB

BIN
lisp/company/images/small/tooltip-minimum-above.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 41 KiB

BIN
lisp/company/images/small/tooltip-minimum-below.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 22 KiB

BIN
lisp/company/images/small/tooltip-offset-display.png Executable file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 28 KiB

BIN
lisp/company/images/small/tooltip-qa-faces-light.png Executable file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 26 KiB

BIN
lisp/company/images/small/tooltip-quick-access.png Executable file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 19 KiB

BIN
lisp/company/images/small/tooltip-search.png Executable file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 44 KiB

7
lisp/compat/.dir-locals.el Normal file
View File

@@ -0,0 +1,7 @@
;;; Directory Local Variables
;;; For more information see (info "(emacs) Directory Variables")
((emacs-lisp-mode
(byte-compile-docstring-max-column . 100)
(show-trailing-whitespace . t)
(indent-tabs-mode . nil)))

108
lisp/compat/NEWS.org Normal file
View File

@@ -0,0 +1,108 @@
#+options: toc:nil num:nil
#+link: compat https://todo.sr.ht/~pkal/compat/
* Release of "Compat" Version 28.1.2.2
This is a minor release that hopes to address [[compat:7]].
(Release <2022-08-25 Thu>)
* Release of "Compat" Version 28.1.2.1
This is a minor release adding the following changes:
- Add =derived-mode-p= defined in Emacs 27
- Add =provided-mode-derived-p= defined in Emacs 27
- Add =read-multiple-choice= defined in Emacs 26
- Add =file-name-absolute-p= defined in Emacs 28
The only other notable change is that the manual has been rewritten to
include much more documentation that had been the case previously.
(Release <2022-08-24 Wed>)
* Release of "Compat" Version 28.1.2.0
The main change of this release has been the major simplification of
Compat's initialisation system, improving the situation around issues
people had been reporting ([[compat:4]], once again) with unconventional
or unpopular packaging systems.
In addition to this, the following functional changes have been made:
- Fix =format-prompt= of an empty string as "default" argument
- Add =decoded-time-period= defined in Emacs 28
- Add =subr-primitive-p= defined in Emacs 28
Minor improvements to manual are also part of this release.
(Release <2022-07-18 Mon>)
* Release of "Compat" Version 28.1.1.3
This release just contains a hot-fix for an issue introduced in the
last version, where compat.el raises an error during byte compilation.
See [[compat:4]].
(Release <2022-06-19 Sun>)
* Release of "Compat" Version 28.1.1.2
Two main changes have necessitated a new patch release:
1. Fix issues related to the loading of compat when uncompiled. See
[[https://lists.sr.ht/~pkal/compat-devel/%3C20220530191000.2183047-1-jonas%40bernoul.li%3E][this thread]] for more details on the problem.
2. Fix issues related to the loading of compat on old pre-releases
(think of 28.0.50). See [[https://lists.sr.ht/~pkal/compat-devel/%3Cf8635d7d-e233-448f-b325-9e850363241c%40www.fastmail.com%3E][this thread]] for more details on the
problem.
(Released <2022-06-22 Wed>)
* Release of "Compat" Version 28.1.1.1
This is a minor release fixing a bug in =json-serialize=, that could
cause unintended side-effects, not related to packages using Compat
directly (see [[compat:2]]).
(Released <2022-05-05 Thu>)
* Release of "Compat" Version 28.1.1.0
This release mostly fixes a number of smaller bugs that were not
identified as of 28.1.0.0. Nevertheless these warrent a version bump,
as some of these changes a functional. These include:
- The addition of the =file-attribute-*= accessor functions.
- The addition of =file-attribute-collect=.
- Improvements to the Texinfo manual (via Jonas Bernoulli's recent
work on =ox-texinfo=). For the time being, the Texinfo file is
maintained in the repository itself, next to the =MANUAL= file.
This might change in the future.
- Adding a prefix to =string-trim=, =string-trim-left= and
=string-trim-right= (i.e. now =compat-string-trim=,
=compat-string-trim-left= and =compat-string-trim-right=)
- Improving the version inference used in the =compat-*= macros.
This improves the compile-time optimisation that strips away
functions that are known to be defined for a specific version.
- The addition of generalised variable (=setf=) support for
=compat-alist-get=.
- The addition of =image-property= and generalised variable support
for =image-property=.
- The addition of the function =compat-executable-find=.
- The addition of the function =compat-dired-get-marked-files=.
- The addition of the function =exec-path=.
- The addition of the function =make-lock-file-name=.
- The addition of the function =null-device=.
- The addition of the function =time-equal-p=.
- The addition of the function =date-days-in-month=.
- Handling out-of-directory byte compilation better.
- Fixing the usage and edge-cases of =and-let*=.
Furthermore a bug tracker was added: https://todo.sr.ht/~pkal/compat,
which is the preferred way to report issues or feature requests.
General problems, questions, etc. are still better discussed on the
development mailing list: https://lists.sr.ht/~pkal/compat-devel.
(Released <2022-04-22 Fri>)

495
lisp/compat/compat-24.el Normal file
View File

@@ -0,0 +1,495 @@
;;; compat-24.el --- Compatibility Layer for Emacs 24.4 -*- lexical-binding: t; -*-
;; Copyright (C) 2021, 2022 Free Software Foundation, Inc.
;; Author: Philip Kaludercic <philipk@posteo.net>
;; Maintainer: Compat Development <~pkal/compat-devel@lists.sr.ht>
;; URL: https://git.sr.ht/~pkal/compat/
;; Keywords: lisp
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; Find here the functionality added in Emacs 24.4, needed by older
;; versions.
;;
;; Only load this library if you need to use one of the following
;; functions:
;;
;; - `compat-='
;; - `compat-<'
;; - `compat->'
;; - `compat-<='
;; - `compat->='
;; - `split-string'.
;;; Code:
(require 'compat-macs "compat-macs.el")
(compat-declare-version "24.4")
;;;; Defined in data.c
(compat-defun = (number-or-marker &rest numbers-or-markers)
"Handle multiple arguments."
:prefix t
(catch 'fail
(while numbers-or-markers
(unless (= number-or-marker (car numbers-or-markers))
(throw 'fail nil))
(setq number-or-marker (pop numbers-or-markers)))
t))
(compat-defun < (number-or-marker &rest numbers-or-markers)
"Handle multiple arguments."
:prefix t
(catch 'fail
(while numbers-or-markers
(unless (< number-or-marker (car numbers-or-markers))
(throw 'fail nil))
(setq number-or-marker (pop numbers-or-markers)))
t))
(compat-defun > (number-or-marker &rest numbers-or-markers)
"Handle multiple arguments."
:prefix t
(catch 'fail
(while numbers-or-markers
(unless (> number-or-marker (car numbers-or-markers))
(throw 'fail nil))
(setq number-or-marker (pop numbers-or-markers)))
t))
(compat-defun <= (number-or-marker &rest numbers-or-markers)
"Handle multiple arguments."
:prefix t
(catch 'fail
(while numbers-or-markers
(unless (<= number-or-marker (car numbers-or-markers))
(throw 'fail nil))
(setq number-or-marker (pop numbers-or-markers)))
t))
(compat-defun >= (number-or-marker &rest numbers-or-markers)
"Handle multiple arguments."
:prefix t
(catch 'fail
(while numbers-or-markers
(unless (>= number-or-marker (pop numbers-or-markers))
(throw 'fail nil)))
t))
(compat-defun bool-vector-exclusive-or (a b &optional c)
"Return A ^ B, bitwise exclusive or.
If optional third argument C is given, store result into C.
A, B, and C must be bool vectors of the same length.
Return the destination vector if it changed or nil otherwise."
(unless (bool-vector-p a)
(signal 'wrong-type-argument (list 'bool-vector-p a)))
(unless (bool-vector-p b)
(signal 'wrong-type-argument (list 'bool-vector-p b)))
(unless (or (null c) (bool-vector-p c))
(signal 'wrong-type-argument (list 'bool-vector-p c)))
(when (/= (length a) (length b))
(signal 'wrong-length-argument (list (length a) (length b))))
(let ((dest (or c (make-bool-vector (length a) nil))) changed)
(when (/= (length a) (length dest))
(signal 'wrong-length-argument (list (length a) (length dest))))
(dotimes (i (length dest))
(let ((val (not (eq (aref a i) (aref b i)))))
(unless (eq val (aref dest i))
(setq changed t))
(aset dest i val)))
(if c (and changed c) dest)))
(compat-defun bool-vector-union (a b &optional c)
"Return A | B, bitwise or.
If optional third argument C is given, store result into C.
A, B, and C must be bool vectors of the same length.
Return the destination vector if it changed or nil otherwise."
(unless (bool-vector-p a)
(signal 'wrong-type-argument (list 'bool-vector-p a)))
(unless (bool-vector-p b)
(signal 'wrong-type-argument (list 'bool-vector-p b)))
(unless (or (null c) (bool-vector-p c))
(signal 'wrong-type-argument (list 'bool-vector-p c)))
(when (/= (length a) (length b))
(signal 'wrong-length-argument (list (length a) (length b))))
(let ((dest (or c (make-bool-vector (length a) nil))) changed)
(when (/= (length a) (length dest))
(signal 'wrong-length-argument (list (length a) (length dest))))
(dotimes (i (length dest))
(let ((val (or (aref a i) (aref b i))))
(unless (eq val (aref dest i))
(setq changed t))
(aset dest i val)))
(if c (and changed c) dest)))
(compat-defun bool-vector-intersection (a b &optional c)
"Return A & B, bitwise and.
If optional third argument C is given, store result into C.
A, B, and C must be bool vectors of the same length.
Return the destination vector if it changed or nil otherwise."
(unless (bool-vector-p a)
(signal 'wrong-type-argument (list 'bool-vector-p a)))
(unless (bool-vector-p b)
(signal 'wrong-type-argument (list 'bool-vector-p b)))
(unless (or (null c) (bool-vector-p c))
(signal 'wrong-type-argument (list 'bool-vector-p c)))
(when (/= (length a) (length b))
(signal 'wrong-length-argument (list (length a) (length b))))
(let ((dest (or c (make-bool-vector (length a) nil))) changed)
(when (/= (length a) (length dest))
(signal 'wrong-length-argument (list (length a) (length dest))))
(dotimes (i (length dest))
(let ((val (and (aref a i) (aref b i))))
(unless (eq val (aref dest i))
(setq changed t))
(aset dest i val)))
(if c (and changed c) dest)))
(compat-defun bool-vector-set-difference (a b &optional c)
"Return A &~ B, set difference.
If optional third argument C is given, store result into C.
A, B, and C must be bool vectors of the same length.
Return the destination vector if it changed or nil otherwise."
(unless (bool-vector-p a)
(signal 'wrong-type-argument (list 'bool-vector-p a)))
(unless (bool-vector-p b)
(signal 'wrong-type-argument (list 'bool-vector-p b)))
(unless (or (null c) (bool-vector-p c))
(signal 'wrong-type-argument (list 'bool-vector-p c)))
(when (/= (length a) (length b))
(signal 'wrong-length-argument (list (length a) (length b))))
(let ((dest (or c (make-bool-vector (length a) nil))) changed)
(when (/= (length a) (length dest))
(signal 'wrong-length-argument (list (length a) (length dest))))
(dotimes (i (length dest))
(let ((val (and (aref a i) (not (aref b i)))))
(unless (eq val (aref dest i))
(setq changed t))
(aset dest i val)))
(if c (and changed c) dest)))
(compat-defun bool-vector-not (a &optional b)
"Compute ~A, set complement.
If optional second argument B is given, store result into B.
A and B must be bool vectors of the same length.
Return the destination vector."
(unless (bool-vector-p a)
(signal 'wrong-type-argument (list 'bool-vector-p a)))
(unless (or (null b) (bool-vector-p b))
(signal 'wrong-type-argument (list 'bool-vector-p b)))
(let ((dest (or b (make-bool-vector (length a) nil))))
(when (/= (length a) (length dest))
(signal 'wrong-length-argument (list (length a) (length dest))))
(dotimes (i (length dest))
(aset dest i (not (aref a i))))
dest))
(compat-defun bool-vector-subsetp (a b)
"Return t if every t value in A is also t in B, nil otherwise.
A and B must be bool vectors of the same length."
(unless (bool-vector-p a)
(signal 'wrong-type-argument (list 'bool-vector-p a)))
(unless (bool-vector-p b)
(signal 'wrong-type-argument (list 'bool-vector-p b)))
(when (/= (length a) (length b))
(signal 'wrong-length-argument (list (length a) (length b))))
(catch 'not-subset
(dotimes (i (length a))
(when (if (aref a i) (not (aref b i)) nil)
(throw 'not-subset nil)))
t))
(compat-defun bool-vector-count-consecutive (a b i)
"Count how many consecutive elements in A equal B starting at I.
A is a bool vector, B is t or nil, and I is an index into A."
(unless (bool-vector-p a)
(signal 'wrong-type-argument (list 'bool-vector-p a)))
(setq b (and b t)) ;normalise to nil or t
(unless (< i (length a))
(signal 'args-out-of-range (list a i)))
(let ((len (length a)) (n i))
(while (and (< i len) (eq (aref a i) b))
(setq i (1+ i)))
(- i n)))
(compat-defun bool-vector-count-population (a)
"Count how many elements in A are t.
A is a bool vector. To count A's nil elements, subtract the
return value from A's length."
(unless (bool-vector-p a)
(signal 'wrong-type-argument (list 'bool-vector-p a)))
(let ((n 0))
(dotimes (i (length a))
(when (aref a i)
(setq n (1+ n))))
n))
;;;; Defined in subr.el
;;* UNTESTED
(compat-defmacro with-eval-after-load (file &rest body)
"Execute BODY after FILE is loaded.
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 (form def-body)))
;; See https://nullprogram.com/blog/2018/02/22/ on how
;; `eval-after-load' is used to preserve compatibility with 24.3.
`(eval-after-load ,file `(funcall ',,`(lambda () ,@body))))
(compat-defun special-form-p (object)
"Non-nil if and only if OBJECT is a special form."
(if (and (symbolp object) (fboundp object))
(setq object (condition-case nil
(indirect-function object)
(void-function nil))))
(and (subrp object) (eq (cdr (subr-arity object)) 'unevalled)))
(compat-defun macrop (object)
"Non-nil if and only if OBJECT is a macro."
(let ((def (condition-case nil
(indirect-function object)
(void-function nil))))
(when (consp def)
(or (eq 'macro (car def))
(and (autoloadp def) (memq (nth 4 def) '(macro t)))))))
(compat-defun string-suffix-p (suffix string &optional ignore-case)
"Return non-nil if SUFFIX is a suffix of STRING.
If IGNORE-CASE is non-nil, the comparison is done without paying
attention to case differences."
(let ((start-pos (- (length string) (length suffix))))
(and (>= start-pos 0)
(eq t (compare-strings suffix nil nil
string start-pos nil ignore-case)))))
(compat-defun split-string (string &optional separators omit-nulls trim)
"Extend `split-string' by a TRIM argument.
The remaining arguments STRING, SEPARATORS and OMIT-NULLS are
handled just as with `split-string'."
:prefix t
(let* ((token (split-string string separators omit-nulls))
(trimmed (if trim
(mapcar
(lambda (token)
(when (string-match (concat "\\`" trim) token)
(setq token (substring token (match-end 0))))
(when (string-match (concat trim "\\'") token)
(setq token (substring token 0 (match-beginning 0))))
token)
token)
token)))
(if omit-nulls (delete "" trimmed) trimmed)))
(compat-defun delete-consecutive-dups (list &optional circular)
"Destructively remove `equal' consecutive duplicates from LIST.
First and last elements are considered consecutive if CIRCULAR is
non-nil."
(let ((tail list) last)
(while (cdr tail)
(if (equal (car tail) (cadr tail))
(setcdr tail (cddr tail))
(setq last tail
tail (cdr tail))))
(if (and circular
last
(equal (car tail) (car list)))
(setcdr last nil)))
list)
;;* UNTESTED
(compat-defun define-error (name message &optional parent)
"Define NAME as a new error signal.
MESSAGE is a string that will be output to the echo area if such an error
is signaled without being caught by a `condition-case'.
PARENT is either a signal or a list of signals from which it inherits.
Defaults to `error'."
(unless parent (setq parent 'error))
(let ((conditions
(if (consp parent)
(apply #'append
(mapcar (lambda (parent)
(cons parent
(or (get parent 'error-conditions)
(error "Unknown signal `%s'" parent))))
parent))
(cons parent (get parent 'error-conditions)))))
(put name 'error-conditions
(delete-dups (copy-sequence (cons name conditions))))
(when message (put name 'error-message message))))
;;;; Defined in minibuffer.el
;;* UNTESTED
(compat-defun completion-table-with-cache (fun &optional ignore-case)
"Create dynamic completion table from function FUN, with cache.
This is a wrapper for `completion-table-dynamic' that saves the last
argument-result pair from FUN, so that several lookups with the
same argument (or with an argument that starts with the first one)
only need to call FUN once. This can be useful when FUN performs a
relatively slow operation, such as calling an external process.
When IGNORE-CASE is non-nil, FUN is expected to be case-insensitive."
(let* (last-arg last-result
(new-fun
(lambda (arg)
(if (and last-arg (string-prefix-p last-arg arg ignore-case))
last-result
(prog1
(setq last-result (funcall fun arg))
(setq last-arg arg))))))
(completion-table-dynamic new-fun)))
;;* UNTESTED
(compat-defun completion-table-merge (&rest tables)
"Create a completion table that collects completions from all TABLES."
(lambda (string pred action)
(cond
((null action)
(let ((retvals (mapcar (lambda (table)
(try-completion string table pred))
tables)))
(if (member string retvals)
string
(try-completion string
(mapcar (lambda (value)
(if (eq value t) string value))
(delq nil retvals))
pred))))
((eq action t)
(apply #'append (mapcar (lambda (table)
(all-completions string table pred))
tables)))
(t
(completion--some (lambda (table)
(complete-with-action action table string pred))
tables)))))
;;;; Defined in subr-x.el
;;* UNTESTED
(compat-advise require (feature &rest args)
"Allow for Emacs 24.x to require the inexistent FEATURE subr-x."
;; As the compatibility advise around `require` is more a hack than
;; of of actual value, the highlighting is suppressed.
:no-highlight t
(if (eq feature 'subr-x)
(let ((entry (assq feature after-load-alist)))
(let ((load-file-name nil))
(dolist (form (cdr entry))
(funcall (eval form t)))))
(apply oldfun feature args)))
(compat-defun hash-table-keys (hash-table)
"Return a list of keys in HASH-TABLE."
(let (values)
(maphash
(lambda (k _v) (push k values))
hash-table)
values))
(compat-defun hash-table-values (hash-table)
"Return a list of values in HASH-TABLE."
(let (values)
(maphash
(lambda (_k v) (push v values))
hash-table)
values))
(compat-defun string-empty-p (string)
"Check whether STRING is empty."
(string= string ""))
(compat-defun string-join (strings &optional separator)
"Join all STRINGS using SEPARATOR.
Optional argument SEPARATOR must be a string, a vector, or a list of
characters; nil stands for the empty string."
(mapconcat #'identity strings separator))
(compat-defun string-blank-p (string)
"Check whether STRING is either empty or only whitespace.
The following characters count as whitespace here: space, tab, newline and
carriage return."
(string-match-p "\\`[ \t\n\r]*\\'" string))
(compat-defun string-remove-prefix (prefix string)
"Remove PREFIX from STRING if present."
(if (string-prefix-p prefix string)
(substring string (length prefix))
string))
(compat-defun string-remove-suffix (suffix string)
"Remove SUFFIX from STRING if present."
(if (string-suffix-p suffix string)
(substring string 0 (- (length string) (length suffix)))
string))
;;;; Defined in faces.el
;;* UNTESTED
(compat-defun face-spec-set (face spec &optional spec-type)
"Set the FACE's spec SPEC, define FACE, and recalculate its attributes.
See `defface' for the format of SPEC.
The appearance of each face is controlled by its specs (set via
this function), and by the internal frame-specific face
attributes (set via `set-face-attribute').
This function also defines FACE as a valid face name if it is not
already one, and (re)calculates its attributes on existing
frames.
The optional argument SPEC-TYPE determines which spec to set:
nil, omitted or `face-override-spec' means the override spec,
which overrides all the other types of spec mentioned below
(this is usually what you want if calling this function
outside of Custom code);
`customized-face' or `saved-face' means the customized spec or
the saved custom spec;
`face-defface-spec' means the default spec
(usually set only via `defface');
`reset' means to ignore SPEC, but clear the `customized-face'
and `face-override-spec' specs;
Any other value means not to set any spec, but to run the
function for defining FACE and recalculating its attributes."
(if (get face 'face-alias)
(setq face (get face 'face-alias)))
;; Save SPEC to the relevant symbol property.
(unless spec-type
(setq spec-type 'face-override-spec))
(if (memq spec-type '(face-defface-spec face-override-spec
customized-face saved-face))
(put face spec-type spec))
(if (memq spec-type '(reset saved-face))
(put face 'customized-face nil))
;; Setting the face spec via Custom empties out any override spec,
;; similar to how setting a variable via Custom changes its values.
(if (memq spec-type '(customized-face saved-face reset))
(put face 'face-override-spec nil))
;; If we reset the face based on its custom spec, it is unmodified
;; as far as Custom is concerned.
(unless (eq face 'face-override-spec)
(put face 'face-modified nil))
;; Initialize the face if it does not exist, then recalculate.
(make-empty-face face)
(dolist (frame (frame-list))
(face-spec-recalc face frame)))
(compat--inhibit-prefixed (provide 'compat-24))
;;; compat-24.el ends here

322
lisp/compat/compat-25.el Normal file
View File

@@ -0,0 +1,322 @@
;;; compat-25.el --- Compatibility Layer for Emacs 25.1 -*- lexical-binding: t; -*-
;; Copyright (C) 2021, 2022 Free Software Foundation, Inc.
;; Author: Philip Kaludercic <philipk@posteo.net>
;; Maintainer: Compat Development <~pkal/compat-devel@lists.sr.ht>
;; URL: https://git.sr.ht/~pkal/compat/
;; Keywords: lisp
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; Find here the functionality added in Emacs 25.1, needed by older
;; versions.
;;
;; Only load this library if you need to use one of the following
;; functions:
;;
;; - `compat-sort'
;;; Code:
(require 'compat-macs "compat-macs.el")
(compat-declare-version "25.1")
;;;; Defined in alloc.c
(compat-defun bool-vector (&rest objects)
"Return a new bool-vector with specified arguments as elements.
Allows any number of arguments, including zero.
usage: (bool-vector &rest OBJECTS)"
(let ((vec (make-bool-vector (length objects) nil))
(i 0))
(while objects
(when (car objects)
(aset vec i t))
(setq objects (cdr objects)
i (1+ i)))
vec))
;;;; Defined in fns.c
(compat-defun sort (seq predicate)
"Extend `sort' to sort SEQ as a vector."
:prefix t
(cond
((listp seq)
(sort seq predicate))
((vectorp seq)
(let ((cseq (sort (append seq nil) predicate)))
(dotimes (i (length cseq))
(setf (aref seq i) (nth i cseq)))
(apply #'vector cseq)))
((signal 'wrong-type-argument 'list-or-vector-p))))
;;;; Defined in editfns.c
(compat-defun format-message (string &rest objects)
"Format a string out of a format-string and arguments.
The first argument is a format control string.
The other arguments are substituted into it to make the result, a string.
This implementation is equivalent to `format'."
(apply #'format string objects))
;;;; Defined in minibuf.c
;; TODO advise read-buffer to handle 4th argument
;;;; Defined in fileio.c
(compat-defun directory-name-p (name)
"Return non-nil if NAME ends with a directory separator character."
:realname compat--directory-name-p
(eq (eval-when-compile
(if (memq system-type '(cygwin windows-nt ms-dos))
?\\ ?/))
(aref name (1- (length name)))))
;;;; Defined in subr.el
(compat-defun string-greaterp (string1 string2)
"Return non-nil if STRING1 is greater than STRING2 in lexicographic order.
Case is significant.
Symbols are also allowed; their print names are used instead."
(string-lessp string2 string1))
;;* UNTESTED
(compat-defmacro with-file-modes (modes &rest body)
"Execute BODY with default file permissions temporarily set to MODES.
MODES is as for `set-default-file-modes'."
(declare (indent 1) (debug t))
(let ((umask (make-symbol "umask")))
`(let ((,umask (default-file-modes)))
(unwind-protect
(progn
(set-default-file-modes ,modes)
,@body)
(set-default-file-modes ,umask)))))
(compat-defun alist-get (key alist &optional default remove testfn)
"Find the first element of ALIST whose `car' equals KEY and return its `cdr'.
If KEY is not found in ALIST, return DEFAULT.
Equality with KEY is tested by TESTFN, defaulting to `eq'."
:realname compat--alist-get-full-elisp
(ignore remove)
(let (entry)
(cond
((or (null testfn) (eq testfn 'eq))
(setq entry (assq key alist)))
((eq testfn 'equal)
(setq entry (assoc key alist)))
((catch 'found
(dolist (ent alist)
(when (and (consp ent) (funcall testfn (car ent) key))
(throw 'found (setq entry ent))))
default)))
(if entry (cdr entry) default)))
;;;; Defined in subr-x.el
(compat-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
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."
:realname compat--if-let
:feature 'subr-x
(declare (indent 2)
(debug ([&or (symbolp form)
(&rest [&or symbolp (symbolp form) (form)])]
body)))
(when (and (<= (length spec) 2)
(not (listp (car spec))))
;; Adjust the single binding case
(setq spec (list spec)))
`(compat--if-let* ,spec ,then ,(macroexp-progn else)))
(compat-defmacro when-let (spec &rest body)
"Bind variables according to SPEC and conditionally evaluate BODY.
Evaluate each binding in turn, stopping if a binding value is nil.
If all are non-nil, return the value of the last form in BODY.
The variable list SPEC is the same as in `if-let'."
:feature 'subr-x
(declare (indent 1) (debug if-let))
`(compat--if-let ,spec ,(macroexp-progn body)))
(compat-defmacro thread-first (&rest forms)
"Thread FORMS elements as the first argument of their successor.
Example:
(thread-first
5
(+ 20)
(/ 25)
-
(+ 40))
Is equivalent to:
(+ (- (/ (+ 5 20) 25)) 40)
Note how the single `-' got converted into a list before
threading."
:feature 'subr-x
(declare (indent 1)
(debug (form &rest [&or symbolp (sexp &rest form)])))
(let ((body (car forms)))
(dolist (form (cdr forms))
(when (symbolp form)
(setq form (list form)))
(setq body (append (list (car form))
(list body)
(cdr form))))
body))
(compat-defmacro thread-last (&rest forms)
"Thread FORMS elements as the last argument of their successor.
Example:
(thread-last
5
(+ 20)
(/ 25)
-
(+ 40))
Is equivalent to:
(+ 40 (- (/ 25 (+ 20 5))))
Note how the single `-' got converted into a list before
threading."
:feature 'subr-x
(declare (indent 1) (debug thread-first))
(let ((body (car forms)))
(dolist (form (cdr forms))
(when (symbolp form)
(setq form (list form)))
(setq body (append form (list body))))
body))
;;;; Defined in macroexp.el
(declare-function macrop nil (object))
(compat-defun macroexpand-1 (form &optional environment)
"Perform (at most) one step of macro expansion."
:feature 'macroexp
(cond
((consp form)
(let* ((head (car form))
(env-expander (assq head environment)))
(if env-expander
(if (cdr env-expander)
(apply (cdr env-expander) (cdr form))
form)
(if (not (and (symbolp head) (fboundp head)))
form
(let ((def (autoload-do-load (symbol-function head) head 'macro)))
(cond
;; Follow alias, but only for macros, otherwise we may end up
;; skipping an important compiler-macro (e.g. cl--block-wrapper).
((and (symbolp def) (macrop def)) (cons def (cdr form)))
((not (consp def)) form)
(t
(if (eq 'macro (car def))
(apply (cdr def) (cdr form))
form))))))))
(t form)))
;;;; Defined in byte-run.el
;;* UNTESTED
(compat-defun function-put (func prop value)
"Set FUNCTION's property PROP to VALUE.
The namespace for PROP is shared with symbols.
So far, FUNCTION can only be a symbol, not a lambda expression."
:version "24.4"
(put func prop value))
;;;; Defined in files.el
;;* UNTESTED
(compat-defun directory-files-recursively
(dir regexp &optional include-directories predicate follow-symlinks)
"Return list of all files under directory DIR whose names match REGEXP.
This function works recursively. Files are returned in \"depth
first\" order, and files from each directory are sorted in
alphabetical order. Each file name appears in the returned list
in its absolute form.
By default, the returned list excludes directories, but if
optional argument INCLUDE-DIRECTORIES is non-nil, they are
included.
PREDICATE can be either nil (which means that all subdirectories
of DIR are descended into), t (which means that subdirectories that
can't be read are ignored), or a function (which is called with
the name of each subdirectory, and should return non-nil if the
subdirectory is to be descended into).
If FOLLOW-SYMLINKS is non-nil, symbolic links that point to
directories are followed. Note that this can lead to infinite
recursion."
:realname compat--directory-files-recursively
(let* ((result nil)
(files nil)
(dir (directory-file-name dir))
;; When DIR is "/", remote file names like "/method:" could
;; also be offered. We shall suppress them.
(tramp-mode (and tramp-mode (file-remote-p (expand-file-name dir)))))
(dolist (file (sort (file-name-all-completions "" dir)
'string<))
(unless (member file '("./" "../"))
(if (directory-name-p file)
(let* ((leaf (substring file 0 (1- (length file))))
(full-file (concat dir "/" leaf)))
;; Don't follow symlinks to other directories.
(when (and (or (not (file-symlink-p full-file))
(and (file-symlink-p full-file)
follow-symlinks))
;; Allow filtering subdirectories.
(or (eq predicate nil)
(eq predicate t)
(funcall predicate full-file)))
(let ((sub-files
(if (eq predicate t)
(condition-case nil
(compat--directory-files-recursively
full-file regexp include-directories
predicate follow-symlinks)
(file-error nil))
(compat--directory-files-recursively
full-file regexp include-directories
predicate follow-symlinks))))
(setq result (nconc result sub-files))))
(when (and include-directories
(string-match regexp leaf))
(setq result (nconc result (list full-file)))))
(when (string-match regexp file)
(push (concat dir "/" file) files)))))
(nconc result (nreverse files))))
(compat--inhibit-prefixed (provide 'compat-25))
;;; compat-25.el ends here

675
lisp/compat/compat-26.el Normal file
View File

@@ -0,0 +1,675 @@
;;; compat-26.el --- Compatibility Layer for Emacs 26.1 -*- lexical-binding: t; -*-
;; Copyright (C) 2021, 2022 Free Software Foundation, Inc.
;; Author: Philip Kaludercic <philipk@posteo.net>
;; Maintainer: Compat Development <~pkal/compat-devel@lists.sr.ht>
;; URL: https://git.sr.ht/~pkal/compat/
;; Keywords: lisp
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; Find here the functionality added in Emacs 26.1, needed by older
;; versions.
;;
;; Only load this library if you need to use one of the following
;; functions:
;;
;; - `compat-sort'
;; - `line-number-at-pos'
;; - `compat-alist-get'
;; - `string-trim-left'
;; - `string-trim-right'
;; - `string-trim'
;;; Code:
(require 'compat-macs "compat-macs.el")
(compat-declare-version "26.1")
;;;; Defined in eval.c
(compat-defun func-arity (func)
"Return minimum and maximum number of args allowed for FUNC.
FUNC must be a function of some kind.
The returned value is a cons cell (MIN . MAX). MIN is the minimum number
of args. MAX is the maximum number, or the symbol `many', for a
function with `&rest' args, or `unevalled' for a special form."
:realname compat--func-arity
(cond
((or (null func) (and (symbolp func) (not (fboundp func))))
(signal 'void-function func))
((and (symbolp func) (not (null func)))
(compat--func-arity (symbol-function func)))
((eq (car-safe func) 'macro)
(compat--func-arity (cdr func)))
((subrp func)
(subr-arity func))
((memq (car-safe func) '(closure lambda))
;; See lambda_arity from eval.c
(when (eq (car func) 'closure)
(setq func (cdr func)))
(let ((syms-left (if (consp func)
(car func)
(signal 'invalid-function func)))
(min-args 0) (max-args 0) optional)
(catch 'many
(dolist (next syms-left)
(cond
((not (symbolp next))
(signal 'invalid-function func))
((eq next '&rest)
(throw 'many (cons min-args 'many)))
((eq next '&optional)
(setq optional t))
(t (unless optional
(setq min-args (1+ min-args)))
(setq max-args (1+ max-args)))))
(cons min-args max-args))))
((and (byte-code-function-p func) (numberp (aref func 0)))
;; See get_byte_code_arity from bytecode.c
(let ((at (aref func 0)))
(cons (logand at 127)
(if (= (logand at 128) 0)
(ash at -8)
'many))))
((and (byte-code-function-p func) (numberp (aref func 0)))
;; See get_byte_code_arity from bytecode.c
(let ((at (aref func 0)))
(cons (logand at 127)
(if (= (logand at 128) 0)
(ash at -8)
'many))))
((and (byte-code-function-p func) (listp (aref func 0)))
;; Based on `byte-compile-make-args-desc', this is required for
;; old versions of Emacs that don't use a integer for the argument
;; list description, per e2abe5a13dffb08d6371b6a611bc39c3a9ac2bc6.
(let ((arglist (aref func 0)) (mandatory 0) nonrest)
(while (and arglist (not (memq (car arglist) '(&optional &rest))))
(setq mandatory (1+ mandatory))
(setq arglist (cdr arglist)))
(setq nonrest mandatory)
(when (eq (car arglist) '&optional)
(setq arglist (cdr arglist))
(while (and arglist (not (eq (car arglist) '&rest)))
(setq nonrest (1+ nonrest))
(setq arglist (cdr arglist))))
(cons mandatory (if arglist 'many nonrest))))
((autoloadp func)
(autoload-do-load func)
(compat--func-arity func))
((signal 'invalid-function func))))
;;;; Defined in fns.c
(compat-defun assoc (key alist &optional testfn)
"Handle the optional argument TESTFN.
Equality is defined by the function TESTFN, defaulting to
`equal'. TESTFN is called with 2 arguments: a car of an alist
element and KEY. With no optional argument, the function behaves
just like `assoc'."
:prefix t
(if testfn
(catch 'found
(dolist (ent alist)
(when (funcall testfn (car ent) key)
(throw 'found ent))))
(assoc key alist)))
(compat-defun mapcan (func sequence)
"Apply FUNC to each element of SEQUENCE.
Concatenate the results by altering them (using `nconc').
SEQUENCE may be a list, a vector, a boolean vector, or a string."
(apply #'nconc (mapcar func sequence)))
;;* UNTESTED
(compat-defun line-number-at-pos (&optional position absolute)
"Handle optional argument ABSOLUTE:
If the buffer is narrowed, the return value by default counts the lines
from the beginning of the accessible portion of the buffer. But if the
second optional argument ABSOLUTE is non-nil, the value counts the lines
from the absolute start of the buffer, disregarding the narrowing."
:prefix t
(if absolute
(save-restriction
(widen)
(line-number-at-pos position))
(line-number-at-pos position)))
;;;; Defined in subr.el
(declare-function compat--alist-get-full-elisp "compat-25"
(key alist &optional default remove testfn))
(compat-defun alist-get (key alist &optional default remove testfn)
"Handle TESTFN manually."
:realname compat--alist-get-handle-testfn
:prefix t
(if testfn
(compat--alist-get-full-elisp key alist default remove testfn)
(alist-get key alist default remove)))
(gv-define-expander compat-alist-get
(lambda (do key alist &optional default remove testfn)
(macroexp-let2 macroexp-copyable-p k key
(gv-letplace (getter setter) alist
(macroexp-let2 nil p `(if (and ,testfn (not (eq ,testfn 'eq)))
(compat-assoc ,k ,getter ,testfn)
(assq ,k ,getter))
(funcall do (if (null default) `(cdr ,p)
`(if ,p (cdr ,p) ,default))
(lambda (v)
(macroexp-let2 nil v v
(let ((set-exp
`(if ,p (setcdr ,p ,v)
,(funcall setter
`(cons (setq ,p (cons ,k ,v))
,getter)))))
`(progn
,(cond
((null remove) set-exp)
((or (eql v default)
(and (eq (car-safe v) 'quote)
(eq (car-safe default) 'quote)
(eql (cadr v) (cadr default))))
`(if ,p ,(funcall setter `(delq ,p ,getter))))
(t
`(cond
((not (eql ,default ,v)) ,set-exp)
(,p ,(funcall setter
`(delq ,p ,getter))))))
,v))))))))))
(compat-defun string-trim-left (string &optional regexp)
"Trim STRING of leading string matching REGEXP.
REGEXP defaults to \"[ \\t\\n\\r]+\"."
:realname compat--string-trim-left
:prefix t
(if (string-match (concat "\\`\\(?:" (or regexp "[ \t\n\r]+") "\\)") string)
(substring string (match-end 0))
string))
(compat-defun string-trim-right (string &optional regexp)
"Trim STRING of trailing string matching REGEXP.
REGEXP defaults to \"[ \\t\\n\\r]+\"."
:realname compat--string-trim-right
:prefix t
(let ((i (string-match-p
(concat "\\(?:" (or regexp "[ \t\n\r]+") "\\)\\'")
string)))
(if i (substring string 0 i) string)))
(compat-defun string-trim (string &optional trim-left trim-right)
"Trim STRING of leading with and trailing matching TRIM-LEFT and TRIM-RIGHT.
TRIM-LEFT and TRIM-RIGHT default to \"[ \\t\\n\\r]+\"."
:prefix t
;; `string-trim-left' and `string-trim-right' were moved from subr-x
;; to subr in Emacs 27, so to avoid loading subr-x we use the
;; compatibility function here:
(compat--string-trim-left
(compat--string-trim-right
string
trim-right)
trim-left))
(compat-defun caaar (x)
"Return the `car' of the `car' of the `car' of X."
(declare (pure t))
(car (car (car x))))
(compat-defun caadr (x)
"Return the `car' of the `car' of the `cdr' of X."
(declare (pure t))
(car (car (cdr x))))
(compat-defun cadar (x)
"Return the `car' of the `cdr' of the `car' of X."
(declare (pure t))
(car (cdr (car x))))
(compat-defun caddr (x)
"Return the `car' of the `cdr' of the `cdr' of X."
(declare (pure t))
(car (cdr (cdr x))))
(compat-defun cdaar (x)
"Return the `cdr' of the `car' of the `car' of X."
(declare (pure t))
(cdr (car (car x))))
(compat-defun cdadr (x)
"Return the `cdr' of the `car' of the `cdr' of X."
(declare (pure t))
(cdr (car (cdr x))))
(compat-defun cddar (x)
"Return the `cdr' of the `cdr' of the `car' of X."
(declare (pure t))
(cdr (cdr (car x))))
(compat-defun cdddr (x)
"Return the `cdr' of the `cdr' of the `cdr' of X."
(declare (pure t))
(cdr (cdr (cdr x))))
(compat-defun caaaar (x)
"Return the `car' of the `car' of the `car' of the `car' of X."
(declare (pure t))
(car (car (car (car x)))))
(compat-defun caaadr (x)
"Return the `car' of the `car' of the `car' of the `cdr' of X."
(declare (pure t))
(car (car (car (cdr x)))))
(compat-defun caadar (x)
"Return the `car' of the `car' of the `cdr' of the `car' of X."
(declare (pure t))
(car (car (cdr (car x)))))
(compat-defun caaddr (x)
"Return the `car' of the `car' of the `cdr' of the `cdr' of X."
(declare (pure t))
(car (car (cdr (cdr x)))))
(compat-defun cadaar (x)
"Return the `car' of the `cdr' of the `car' of the `car' of X."
(declare (pure t))
(car (cdr (car (car x)))))
(compat-defun cadadr (x)
"Return the `car' of the `cdr' of the `car' of the `cdr' of X."
(declare (pure t))
(car (cdr (car (cdr x)))))
(compat-defun caddar (x)
"Return the `car' of the `cdr' of the `cdr' of the `car' of X."
(declare (pure t))
(car (cdr (cdr (car x)))))
(compat-defun cadddr (x)
"Return the `car' of the `cdr' of the `cdr' of the `cdr' of X."
(declare (pure t))
(car (cdr (cdr (cdr x)))))
(compat-defun cdaaar (x)
"Return the `cdr' of the `car' of the `car' of the `car' of X."
(declare (pure t))
(cdr (car (car (car x)))))
(compat-defun cdaadr (x)
"Return the `cdr' of the `car' of the `car' of the `cdr' of X."
(declare (pure t))
(cdr (car (car (cdr x)))))
(compat-defun cdadar (x)
"Return the `cdr' of the `car' of the `cdr' of the `car' of X."
(declare (pure t))
(cdr (car (cdr (car x)))))
(compat-defun cdaddr (x)
"Return the `cdr' of the `car' of the `cdr' of the `cdr' of X."
(declare (pure t))
(cdr (car (cdr (cdr x)))))
(compat-defun cddaar (x)
"Return the `cdr' of the `cdr' of the `car' of the `car' of X."
(declare (pure t))
(cdr (cdr (car (car x)))))
(compat-defun cddadr (x)
"Return the `cdr' of the `cdr' of the `car' of the `cdr' of X."
(declare (pure t))
(cdr (cdr (car (cdr x)))))
(compat-defun cdddar (x)
"Return the `cdr' of the `cdr' of the `cdr' of the `car' of X."
(declare (pure t))
(cdr (cdr (cdr (car x)))))
(compat-defun cddddr (x)
"Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X."
(declare (pure t))
(cdr (cdr (cdr (cdr x)))))
(compat-defvar gensym-counter 0
"Number used to construct the name of the next symbol created by `gensym'.")
(compat-defun gensym (&optional prefix)
"Return a new uninterned symbol.
The name is made by appending `gensym-counter' to PREFIX.
PREFIX is a string, and defaults to \"g\"."
(let ((num (prog1 gensym-counter
(setq gensym-counter
(1+ gensym-counter)))))
(make-symbol (format "%s%d" (or prefix "g") num))))
;;;; Defined in files.el
(declare-function temporary-file-directory nil)
;;* UNTESTED
(compat-defun make-nearby-temp-file (prefix &optional dir-flag suffix)
"Create a temporary file as close as possible to `default-directory'.
If PREFIX is a relative file name, and `default-directory' is a
remote file name or located on a mounted file systems, the
temporary file is created in the directory returned by the
function `temporary-file-directory'. Otherwise, the function
`make-temp-file' is used. PREFIX, DIR-FLAG and SUFFIX have the
same meaning as in `make-temp-file'."
(let ((handler (find-file-name-handler
default-directory 'make-nearby-temp-file)))
(if (and handler (not (file-name-absolute-p default-directory)))
(funcall handler 'make-nearby-temp-file prefix dir-flag suffix)
(let ((temporary-file-directory (temporary-file-directory)))
(make-temp-file prefix dir-flag suffix)))))
(compat-defvar mounted-file-systems
(eval-when-compile
(if (memq system-type '(windows-nt cygwin))
"^//[^/]+/"
(concat
"^" (regexp-opt '("/afs/" "/media/" "/mnt" "/net/" "/tmp_mnt/")))))
"File systems that ought to be mounted.")
(compat-defun file-local-name (file)
"Return the local name component of FILE.
This function removes from FILE the specification of the remote host
and the method of accessing the host, leaving only the part that
identifies FILE locally on the remote system.
The returned file name can be used directly as argument of
`process-file', `start-file-process', or `shell-command'."
:realname compat--file-local-name
(or (file-remote-p file 'localname) file))
(compat-defun file-name-quoted-p (name &optional top)
"Whether NAME is quoted with prefix \"/:\".
If NAME is a remote file name and TOP is nil, check the local part of NAME."
:realname compat--file-name-quoted-p
(let ((file-name-handler-alist (unless top file-name-handler-alist)))
(string-prefix-p "/:" (compat--file-local-name name))))
(compat-defun file-name-quote (name &optional top)
"Add the quotation prefix \"/:\" to file NAME.
If NAME is a remote file name and TOP is nil, the local part of
NAME is quoted. If NAME is already a quoted file name, NAME is
returned unchanged."
(let ((file-name-handler-alist (unless top file-name-handler-alist)))
(if (compat--file-name-quoted-p name top)
name
(concat (file-remote-p name) "/:" (compat--file-local-name name)))))
;;* UNTESTED
(compat-defun temporary-file-directory ()
"The directory for writing temporary files.
In case of a remote `default-directory', this is a directory for
temporary files on that remote host. If such a directory does
not exist, or `default-directory' ought to be located on a
mounted file system (see `mounted-file-systems'), the function
returns `default-directory'.
For a non-remote and non-mounted `default-directory', the value of
the variable `temporary-file-directory' is returned."
(let ((handler (find-file-name-handler
default-directory 'temporary-file-directory)))
(if handler
(funcall handler 'temporary-file-directory)
(if (string-match mounted-file-systems default-directory)
default-directory
temporary-file-directory))))
;;* UNTESTED
(compat-defun file-attribute-type (attributes)
"The type field in ATTRIBUTES returned by `file-attributes'.
The value is either t for directory, string (name linked to) for
symbolic link, or nil."
(nth 0 attributes))
;;* UNTESTED
(compat-defun file-attribute-link-number (attributes)
"Return the number of links in ATTRIBUTES returned by `file-attributes'."
(nth 1 attributes))
;;* UNTESTED
(compat-defun file-attribute-user-id (attributes)
"The UID field in ATTRIBUTES returned by `file-attributes'.
This is either a string or a number. If a string value cannot be
looked up, a numeric value, either an integer or a float, is
returned."
(nth 2 attributes))
;;* UNTESTED
(compat-defun file-attribute-group-id (attributes)
"The GID field in ATTRIBUTES returned by `file-attributes'.
This is either a string or a number. If a string value cannot be
looked up, a numeric value, either an integer or a float, is
returned."
(nth 3 attributes))
;;* UNTESTED
(compat-defun file-attribute-access-time (attributes)
"The last access time in ATTRIBUTES returned by `file-attributes'.
This a Lisp timestamp in the style of `current-time'."
(nth 4 attributes))
;;* UNTESTED
(compat-defun file-attribute-modification-time (attributes)
"The modification time in ATTRIBUTES returned by `file-attributes'.
This is the time of the last change to the file's contents, and
is a Lisp timestamp in the style of `current-time'."
(nth 5 attributes))
;;* UNTESTED
(compat-defun file-attribute-status-change-time (attributes)
"The status modification time in ATTRIBUTES returned by `file-attributes'.
This is the time of last change to the file's attributes: owner
and group, access mode bits, etc., and is a Lisp timestamp in the
style of `current-time'."
(nth 6 attributes))
;;* UNTESTED
(compat-defun file-attribute-size (attributes)
"The integer size (in bytes) in ATTRIBUTES returned by `file-attributes'."
(nth 7 attributes))
;;* UNTESTED
(compat-defun file-attribute-modes (attributes)
"The file modes in ATTRIBUTES returned by `file-attributes'.
This is a string of ten letters or dashes as in ls -l."
(nth 8 attributes))
;;* UNTESTED
(compat-defun file-attribute-inode-number (attributes)
"The inode number in ATTRIBUTES returned by `file-attributes'.
It is a nonnegative integer."
(nth 10 attributes))
;;* UNTESTED
(compat-defun file-attribute-device-number (attributes)
"The file system device number in ATTRIBUTES returned by `file-attributes'.
It is an integer."
(nth 11 attributes))
(compat-defun file-attribute-collect (attributes &rest attr-names)
"Return a sublist of ATTRIBUTES returned by `file-attributes'.
ATTR-NAMES are symbols with the selected attribute names.
Valid attribute names are: type, link-number, user-id, group-id,
access-time, modification-time, status-change-time, size, modes,
inode-number and device-number."
(let ((idx '((type . 0)
(link-number . 1)
(user-id . 2)
(group-id . 3)
(access-time . 4)
(modification-time . 5)
(status-change-time . 6)
(size . 7)
(modes . 8)
(inode-number . 10)
(device-number . 11)))
result)
(while attr-names
(let ((attr (pop attr-names)))
(if (assq attr idx)
(push (nth (cdr (assq attr idx))
attributes)
result)
(error "Wrong attribute name '%S'" attr))))
(nreverse result)))
;;;; Defined in subr-x.el
(compat-defmacro if-let* (varlist then &rest else)
"Bind variables according to VARLIST and evaluate THEN or ELSE.
This is like `if-let' but doesn't handle a VARLIST of the form
\(SYMBOL SOMETHING) specially."
:realname compat--if-let*
:feature 'subr-x
(declare (indent 2)
(debug ((&rest [&or symbolp (symbolp form) (form)])
body)))
(let ((empty (make-symbol "s"))
(last t) list)
(dolist (var varlist)
(push `(,(if (cdr var) (car var) empty)
(and ,last ,(or (cadr var) (car var))))
list)
(when (or (cdr var) (consp (car var)))
(setq last (caar list))))
`(let* ,(nreverse list)
(if ,(caar list) ,then ,@else))))
(compat-defmacro when-let* (varlist &rest body)
"Bind variables according to VARLIST and conditionally evaluate BODY.
This is like `when-let' but doesn't handle a VARLIST of the form
\(SYMBOL SOMETHING) specially."
;; :feature 'subr-x
(declare (indent 1) (debug if-let*))
(let ((empty (make-symbol "s"))
(last t) list)
(dolist (var varlist)
(push `(,(if (cdr var) (car var) empty)
(and ,last ,(or (cadr var) (car var))))
list)
(when (or (cdr var) (consp (car var)))
(setq last (caar list))))
`(let* ,(nreverse list)
(when ,(caar list) ,@body))))
(compat-defmacro and-let* (varlist &rest body)
"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."
:feature 'subr-x
(declare (indent 1) (debug if-let*))
(let ((empty (make-symbol "s"))
(last t) list)
(dolist (var varlist)
(push `(,(if (cdr var) (car var) empty)
(and ,last ,(or (cadr var) (car var))))
list)
(when (or (cdr var) (consp (car var)))
(setq last (caar list))))
`(let* ,(nreverse list)
(if ,(caar list) ,(macroexp-progn (or body '(t)))))))
;;;; Defined in image.el
;;* UNTESTED
(compat-defun image-property (image property)
"Return the value of PROPERTY in IMAGE.
Properties can be set with
(setf (image-property IMAGE PROPERTY) VALUE)
If VALUE is nil, PROPERTY is removed from IMAGE."
(plist-get (cdr image) property))
;;* UNTESTED
(unless (get 'image-property 'gv-expander)
(gv-define-setter image-property (image property value)
(let ((image* (make-symbol "image"))
(property* (make-symbol "property"))
(value* (make-symbol "value")))
`(let ((,image* ,image)
(,property* ,property)
(,value* ,value))
(if
(null ,value*)
(while
(cdr ,image*)
(if
(eq
(cadr ,image*)
,property*)
(setcdr ,image*
(cdddr ,image*))
(setq ,image*
(cddr ,image*))))
(setcdr ,image*
(plist-put
(cdr ,image*)
,property* ,value*)))))))
;;;; Defined in rmc.el
;;*UNTESTED
(compat-defun read-multiple-choice
(prompt choices &optional _help-string _show-help long-form)
"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).
If LONG-FORM, do a `completing-read' over the NAME elements in
CHOICES instead."
:note "This is a partial implementation of `read-multiple-choice', that
among other things doesn't offer any help and ignores the
optional DESCRIPTION field."
(if long-form
(let ((options (mapconcat #'cadr choices "/"))
choice)
(setq prompt (concat prompt " (" options "): "))
(setq choice (completing-read prompt (mapcar #'cadr choices) nil t))
(catch 'found
(dolist (option choices)
(when (string= choice (cadr option))
(throw 'found option)))
(error "Invalid choice")))
(let ((options
(mapconcat
(lambda (opt)
(format
"[%s] %s"
(key-description (string (car opt)))
(cadr opt)))
choices " "))
choice)
(setq prompt (concat prompt " (" options "): "))
(while (not (setq choice (assq (read-char prompt) choices)))
(message "Invalid choice")
(sit-for 1))
choice)))
(compat--inhibit-prefixed (provide 'compat-26))
;;; compat-26.el ends here

764
lisp/compat/compat-27.el Normal file
View File

@@ -0,0 +1,764 @@
;;; compat-27.el --- Compatibility Layer for Emacs 27.1 -*- lexical-binding: t; -*-
;; Copyright (C) 2021, 2022 Free Software Foundation, Inc.
;; Author: Philip Kaludercic <philipk@posteo.net>
;; Maintainer: Compat Development <~pkal/compat-devel@lists.sr.ht>
;; URL: https://git.sr.ht/~pkal/compat/
;; Keywords: lisp
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; Find here the functionality added in Emacs 27.1, needed by older
;; versions.
;;
;; Only load this library if you need to use one of the following
;; functions or macros:
;;
;; - `compat-recenter'
;; - `compat-lookup-key'
;; - `compat-setq-local'
;; - `compat-assoc-delete-all'
;; - `compat-file-size-human-readable'
;; - `compat-executable-find'
;; - `compat-regexp-opt'
;; - `compat-dired-get-marked-files'
;;; Code:
(require 'compat-macs "compat-macs.el")
(compat-declare-version "27.1")
;;;; Defined in fns.c
(compat-defun proper-list-p (object)
"Return OBJECT's length if it is a proper list, nil otherwise.
A proper list is neither circular nor dotted (i.e., its last cdr
is nil)."
:min-version "26.1"
:max-version "26.3"
:realname compat--proper-list-p-length-signal
(condition-case nil
(and (listp object) (length object))
(wrong-type-argument nil)
(circular-list nil)))
(compat-defun proper-list-p (object)
"Return OBJECT's length if it is a proper list, nil otherwise.
A proper list is neither circular nor dotted (i.e., its last cdr
is nil)."
:max-version "25.3"
:realname compat--proper-list-p-tortoise-hare
(when (listp object)
(catch 'cycle
(let ((hare object) (tortoise object)
(max 2) (q 2))
(while (consp hare)
(setq hare (cdr hare))
(when (and (or (/= 0 (setq q (1- q)))
(ignore
(setq max (ash max 1)
q max
tortoise hare)))
(eq hare tortoise))
(throw 'cycle nil)))
(and (null hare) (length object))))))
(compat-defun string-distance (string1 string2 &optional bytecompare)
"Return Levenshtein distance between STRING1 and STRING2.
The distance is the number of deletions, insertions, and substitutions
required to transform STRING1 into STRING2.
If BYTECOMPARE is nil or omitted, compute distance in terms of characters.
If BYTECOMPARE is non-nil, compute distance in terms of bytes.
Letter-case is significant, but text properties are ignored."
;; https://en.wikipedia.org/wiki/Levenshtein_distance
(let ((s1 (if bytecompare
(encode-coding-string string1 'raw-text)
(concat string1 "")))
(s2 (if bytecompare
(encode-coding-string string2 'raw-text)
string2)))
(let* ((len1 (length s1))
(len2 (length s2))
(column (make-vector (1+ len1) 0)))
(dotimes (y len1)
(setf (aref column (1+ y)) y))
(dotimes (x len2)
(setf (aref column 0) (1+ x))
(let ((lastdiag x) olddiag)
(dotimes (y len1)
(setf olddiag (aref column (1+ y))
(aref column (1+ y))
(min (+ (if (= (aref s1 y) (aref s2 x)) 0 1)
lastdiag)
(1+ (aref column (1+ y)))
(1+ (aref column y)))
lastdiag olddiag))))
(aref column len1))))
;;;; Defined in window.c
(compat-defun recenter (&optional arg redisplay)
"Handle optional argument REDISPLAY."
:prefix t
(recenter arg)
(when (and redisplay recenter-redisplay)
(redisplay)))
;;;; Defined in keymap.c
(compat-defun lookup-key (keymap key &optional accept-default)
"Allow for KEYMAP to be a list of keymaps."
:prefix t
(cond
((keymapp keymap)
(lookup-key keymap key accept-default))
((listp keymap)
(catch 'found
(dolist (map keymap)
(let ((fn (lookup-key map key accept-default)))
(when fn (throw 'found fn))))))
((signal 'wrong-type-argument (list 'keymapp keymap)))))
;;;; Defined in json.c
(declare-function json-parse-string nil (string &rest args))
(declare-function json-encode "json" (object))
(declare-function json-read-from-string "json" (string))
(declare-function json-read "json" ())
(defvar json-encoding-pretty-print)
(defvar json-object-type)
(defvar json-array-type)
(defvar json-false)
(defvar json-null)
;; The function is declared to satisfy the byte compiler while testing
;; if native JSON parsing is available.;
(declare-function json-serialize nil (object &rest args))
(compat-defun json-serialize (object &rest args)
"Return the JSON representation of OBJECT as a string.
OBJECT must be t, a number, string, vector, hashtable, alist, plist,
or the Lisp equivalents to the JSON null and false values, and its
elements must recursively consist of the same kinds of values. t will
be converted to the JSON true value. Vectors will be converted to
JSON arrays, whereas hashtables, alists and plists are converted to
JSON objects. Hashtable keys must be strings without embedded null
characters and must be unique within each object. Alist and plist
keys must be symbols; if a key is duplicate, the first instance is
used.
The Lisp equivalents to the JSON null and false values are
configurable in the arguments ARGS, a list of keyword/argument pairs:
The keyword argument `:null-object' specifies which object to use
to represent a JSON null value. It defaults to `:null'.
The keyword argument `:false-object' specifies which object to use to
represent a JSON false value. It defaults to `:false'.
In you specify the same value for `:null-object' and `:false-object',
a potentially ambiguous situation, the JSON output will not contain
any JSON false values."
:cond (not (condition-case nil
(equal (json-serialize '()) "{}")
(:success t)
(void-function nil)
(json-unavailable nil)))
:realname compat--json-serialize
(require 'json)
(letrec ((fix (lambda (obj)
(cond
((hash-table-p obj)
(let ((ht (copy-hash-table obj)))
(maphash
(lambda (key val)
(unless (stringp key)
(signal
'wrong-type-argument
(list 'stringp key)))
(puthash key (funcall fix val) ht))
obj)
ht))
((and (listp obj) (consp (car obj))) ;alist
(mapcar
(lambda (ent)
(cons (symbol-name (car ent))
(funcall fix (cdr ent))))
obj))
((listp obj) ;plist
(let (alist)
(while obj
(push (cons (cond
((keywordp (car obj))
(substring
(symbol-name (car obj))
1))
((symbolp (car obj))
(symbol-name (car obj)))
((signal
'wrong-type-argument
(list 'symbolp (car obj)))))
(funcall fix (cadr obj)))
alist)
(unless (consp (cdr obj))
(signal 'wrong-type-argument '(consp nil)))
(setq obj (cddr obj)))
(nreverse alist)))
((vectorp obj)
(let ((vec (make-vector (length obj) nil)))
(dotimes (i (length obj))
(aset vec i (funcall fix (aref obj i))))
vec))
(obj))))
(json-encoding-pretty-print nil)
(json-false (or (plist-get args :false-object) :false))
(json-null (or (plist-get args :null-object) :null)))
(json-encode (funcall fix object))))
(compat-defun json-insert (object &rest args)
"Insert the JSON representation of OBJECT before point.
This is the same as (insert (json-serialize OBJECT)), but potentially
faster. See the function `json-serialize' for allowed values of
OBJECT."
:cond (not (condition-case nil
(equal (json-serialize '()) "{}")
(:success t)
(void-function nil)
(json-unavailable nil)))
(insert (apply #'compat--json-serialize object args)))
(compat-defun json-parse-string (string &rest args)
"Parse the JSON STRING into a Lisp object.
This is essentially the reverse operation of `json-serialize', which
see. The returned object will be the JSON null value, the JSON false
value, t, a number, a string, a vector, a list, a hashtable, an alist,
or a plist. Its elements will be further objects of these types. If
there are duplicate keys in an object, all but the last one are
ignored. If STRING doesn't contain a valid JSON object, this function
signals an error of type `json-parse-error'.
The arguments ARGS are a list of keyword/argument pairs:
The keyword argument `:object-type' specifies which Lisp type is used
to represent objects; it can be `hash-table', `alist' or `plist'. It
defaults to `hash-table'.
The keyword argument `:array-type' specifies which Lisp type is used
to represent arrays; it can be `array' (the default) or `list'.
The keyword argument `:null-object' specifies which object to use
to represent a JSON null value. It defaults to `:null'.
The keyword argument `:false-object' specifies which object to use to
represent a JSON false value. It defaults to `:false'."
:cond (not (condition-case nil
(equal (json-serialize '()) "{}")
(:success t)
(void-function nil)
(json-unavailable nil)))
(require 'json)
(condition-case err
(let ((json-object-type (or (plist-get args :object-type) 'hash-table))
(json-array-type (or (plist-get args :array-type) 'vector))
(json-false (or (plist-get args :false-object) :false))
(json-null (or (plist-get args :null-object) :null)))
(when (eq json-array-type 'array)
(setq json-array-type 'vector))
(json-read-from-string string))
(json-error (signal 'json-parse-error err))))
(compat-defun json-parse-buffer (&rest args)
"Read JSON object from current buffer starting at point.
Move point after the end of the object if parsing was successful.
On error, don't move point.
The returned object will be a vector, list, hashtable, alist, or
plist. Its elements will be the JSON null value, the JSON false
value, t, numbers, strings, or further vectors, lists, hashtables,
alists, or plists. If there are duplicate keys in an object, all
but the last one are ignored.
If the current buffer doesn't contain a valid JSON object, the
function signals an error of type `json-parse-error'.
The arguments ARGS are a list of keyword/argument pairs:
The keyword argument `:object-type' specifies which Lisp type is used
to represent objects; it can be `hash-table', `alist' or `plist'. It
defaults to `hash-table'.
The keyword argument `:array-type' specifies which Lisp type is used
to represent arrays; it can be `array' (the default) or `list'.
The keyword argument `:null-object' specifies which object to use
to represent a JSON null value. It defaults to `:null'.
The keyword argument `:false-object' specifies which object to use to
represent a JSON false value. It defaults to `:false'."
:cond (not (condition-case nil
(equal (json-serialize '()) "{}")
(:success t)
(void-function nil)
(json-unavailable nil)))
(require 'json)
(condition-case err
(let ((json-object-type (or (plist-get args :object-type) 'hash-table))
(json-array-type (or (plist-get args :array-type) 'vector))
(json-false (or (plist-get args :false-object) :false))
(json-null (or (plist-get args :null-object) :null)))
(when (eq json-array-type 'array)
(setq json-array-type 'vector))
(json-read))
(json-error (signal 'json-parse-buffer err))))
;;;; Defined in timefns.c
(compat-defun time-equal-p (t1 t2)
"Return non-nil if time value T1 is equal to time value T2.
A nil value for either argument stands for the current time."
:note "This function is not as accurate as the actual `time-equal-p'."
(cond
((eq t1 t2))
((and (consp t1) (consp t2))
(equal t1 t2))
((let ((now (current-time)))
;; Due to inaccuracies and the relatively slow evaluating of
;; Emacs Lisp compared to C, we allow for slight inaccuracies
;; (less than a millisecond) when comparing time values.
(< (abs (- (float-time (or t1 now))
(float-time (or t2 now))))
1e-5)))))
;;;; Defined in fileio.c
(compat-defun file-name-absolute-p (filename)
"Return t if FILENAME is an absolute file name.
On Unix, absolute file names start with `/'. In Emacs, an absolute
file name can also start with an initial `~' or `~USER' component,
where USER is a valid login name."
;; See definitions in filename.h
(let ((seperator
(eval-when-compile
(if (memq system-type '(cygwin windows-nt ms-dos))
"[\\/]" "/")))
(drive
(eval-when-compile
(cond
((memq system-type '(windows-nt ms-dos))
"\\`[A-Za-z]:[\\/]")
((eq system-type 'cygwin)
"\\`\\([\\/]\\|[A-Za-z]:\\)")
("\\`/"))))
(home
(eval-when-compile
(if (memq system-type '(cygwin windows-nt ms-dos))
"\\`~[\\/]" "\\`~/")))
(user-home
(eval-when-compile
(format "\\`\\(~.*?\\)\\(%s.*\\)?$"
(if (memq system-type '(cygwin windows-nt ms-dos))
"[\\/]" "/")))))
(or (and (string-match-p drive filename) t)
(and (string-match-p home filename) t)
(save-excursion
(when (string-match user-home filename)
(let ((init (match-string 1 filename)))
(not (string=
(file-name-base (expand-file-name init))
init))))))))
;;;; Defined in subr.el
(compat-defmacro setq-local (&rest pairs)
"Handle multiple assignments."
:prefix t
(unless (zerop (mod (length pairs) 2))
(error "PAIRS must have an even number of variable/value members"))
(let (body)
(while pairs
(let* ((sym (pop pairs))
(val (pop pairs)))
(unless (symbolp sym)
(error "Attempting to set a non-symbol: %s" (car pairs)))
(push `(set (make-local-variable ,sym) ,val)
body)))
(cons 'progn (nreverse body))))
(compat-defun provided-mode-derived-p (mode &rest modes)
"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'."
:realname compat--provided-mode-derived-p
;; If MODE is an alias, then look up the real mode function first.
(let ((alias (symbol-function mode)))
(when (and alias (symbolp alias))
(setq mode alias)))
(while
(and
(not (memq mode modes))
(let* ((parent (get mode 'derived-mode-parent))
(parentfn (symbol-function parent)))
(setq mode (if (and parentfn (symbolp parentfn)) parentfn parent)))))
mode)
;;* UNTESTED
(defun derived-mode-p (&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."
(apply #'compat--provided-mode-derived-p major-mode modes))
;;* UNTESTED
(compat-defmacro ignore-error (condition &rest body)
"Execute BODY; if the error CONDITION occurs, return nil.
Otherwise, return result of last form in BODY.
CONDITION can also be a list of error conditions."
(declare (debug t) (indent 1))
`(condition-case nil (progn ,@body) (,condition nil)))
;;* UNTESTED
(compat-defmacro dolist-with-progress-reporter (spec reporter-or-message &rest body)
"Loop over a list and report progress in the echo area.
Evaluate BODY with VAR bound to each car from LIST, in turn.
Then evaluate RESULT to get return value, default nil.
REPORTER-OR-MESSAGE is a progress reporter object or a string. In the latter
case, use this string to create a progress reporter.
At each iteration, print the reporter message followed by progress
percentage in the echo area. After the loop is finished,
print the reporter message followed by the word \"done\".
\(fn (VAR LIST [RESULT]) REPORTER-OR-MESSAGE BODY...)"
(declare (indent 2) (debug ((symbolp form &optional form) form body)))
(let ((prep (make-symbol "--dolist-progress-reporter--"))
(count (make-symbol "--dolist-count--"))
(list (make-symbol "--dolist-list--")))
`(let ((,prep ,reporter-or-message)
(,count 0)
(,list ,(cadr spec)))
(when (stringp ,prep)
(setq ,prep (make-progress-reporter ,prep 0 (1- (length ,list)))))
(dolist (,(car spec) ,list)
,@body
(progress-reporter-update ,prep (setq ,count (1+ ,count))))
(progress-reporter-done ,prep)
(or ,@(cdr (cdr spec)) nil))))
(compat-defun flatten-tree (tree)
"Return a \"flattened\" copy of TREE.
In other words, return a list of the non-nil terminal nodes, or
leaves, of the tree of cons cells rooted at TREE. Leaves in the
returned list are in the same order as in TREE.
\(flatten-tree \\='(1 (2 . 3) nil (4 5 (6)) 7))
=> (1 2 3 4 5 6 7)"
(let (elems)
(while (consp tree)
(let ((elem (pop tree)))
(while (consp elem)
(push (cdr elem) tree)
(setq elem (car elem)))
(if elem (push elem elems))))
(if tree (push tree elems))
(nreverse elems)))
(compat-defun xor (cond1 cond2)
"Return the boolean exclusive-or of COND1 and COND2.
If only one of the arguments is non-nil, return it; otherwise
return nil."
(declare (pure t) (side-effect-free error-free))
(cond ((not cond1) cond2)
((not cond2) cond1)))
(compat-defvar regexp-unmatchable "\\`a\\`"
"Standard regexp guaranteed not to match any string at all."
:constant t)
(compat-defun assoc-delete-all (key alist &optional test)
"Delete from ALIST all elements whose car is KEY.
Compare keys with TEST. Defaults to `equal'.
Return the modified alist.
Elements of ALIST that are not conses are ignored."
:prefix t
(unless test (setq test #'equal))
(while (and (consp (car alist))
(funcall test (caar alist) key))
(setq alist (cdr alist)))
(let ((tail alist) tail-cdr)
(while (setq tail-cdr (cdr tail))
(if (and (consp (car tail-cdr))
(funcall test (caar tail-cdr) key))
(setcdr tail (cdr tail-cdr))
(setq tail tail-cdr))))
alist)
;;;; Defined in simple.el
;;* UNTESTED
(compat-defun decoded-time-second (time)
"The seconds in TIME, which is a value returned by `decode-time'.
This is an integer between 0 and 60 (inclusive). (60 is a leap
second, which only some operating systems support.)"
(nth 0 time))
;;* UNTESTED
(compat-defun decoded-time-minute (time)
"The minutes in TIME, which is a value returned by `decode-time'.
This is an integer between 0 and 59 (inclusive)."
(nth 1 time))
;;* UNTESTED
(compat-defun decoded-time-hour (time)
"The hours in TIME, which is a value returned by `decode-time'.
This is an integer between 0 and 23 (inclusive)."
(nth 2 time))
;;* UNTESTED
(compat-defun decoded-time-day (time)
"The day-of-the-month in TIME, which is a value returned by `decode-time'.
This is an integer between 1 and 31 (inclusive)."
(nth 3 time))
;;* UNTESTED
(compat-defun decoded-time-month (time)
"The month in TIME, which is a value returned by `decode-time'.
This is an integer between 1 and 12 (inclusive). January is 1."
(nth 4 time))
;;* UNTESTED
(compat-defun decoded-time-year (time)
"The year in TIME, which is a value returned by `decode-time'.
This is a four digit integer."
(nth 5 time))
;;* UNTESTED
(compat-defun decoded-time-weekday (time)
"The day-of-the-week in TIME, which is a value returned by `decode-time'.
This is a number between 0 and 6, and 0 is Sunday."
(nth 6 time))
;;* UNTESTED
(compat-defun decoded-time-dst (time)
"The daylight saving time in TIME, which is a value returned by `decode-time'.
This is t if daylight saving time is in effect, and nil if not."
(nth 7 time))
;;* UNTESTED
(compat-defun decoded-time-zone (time)
"The time zone in TIME, which is a value returned by `decode-time'.
This is an integer indicating the UTC offset in seconds, i.e.,
the number of seconds east of Greenwich."
(nth 8 time))
;; TODO define gv-setters
;;;; Defined in files.el
(compat-defun file-size-human-readable (file-size &optional flavor space unit)
"Handle the optional third and forth argument:
Optional third argument SPACE is a string put between the number and unit.
It defaults to the empty string. We recommend a single space or
non-breaking space, unless other constraints prohibit a space in that
position.
Optional fourth argument UNIT is the unit to use. It defaults to \"B\"
when FLAVOR is `iec' and the empty string otherwise. We recommend \"B\"
in all cases, since that is the standard symbol for byte."
:prefix t
(let ((power (if (or (null flavor) (eq flavor 'iec))
1024.0
1000.0))
(prefixes '("" "k" "M" "G" "T" "P" "E" "Z" "Y")))
(while (and (>= file-size power) (cdr prefixes))
(setq file-size (/ file-size power)
prefixes (cdr prefixes)))
(let* ((prefix (car prefixes))
(prefixed-unit (if (eq flavor 'iec)
(concat
(if (string= prefix "k") "K" prefix)
(if (string= prefix "") "" "i")
(or unit "B"))
(concat prefix unit))))
(format (if (and (>= (mod file-size 1.0) 0.05)
(< (mod file-size 1.0) 0.95))
"%.1f%s%s"
"%.0f%s%s")
file-size
(if (string= prefixed-unit "") "" (or space ""))
prefixed-unit))))
(declare-function compat--file-name-quote "compat-26"
(name &optional top))
;;*UNTESTED
(compat-defun exec-path ()
"Return list of directories to search programs to run in remote subprocesses.
The remote host is identified by `default-directory'. For remote
hosts that do not support subprocesses, this returns nil.
If `default-directory' is a local directory, this function returns
the value of the variable `exec-path'."
:realname compat--exec-path
(cond
((let ((handler (find-file-name-handler default-directory 'exec-path)))
;; FIXME: The handler was added in 27.1, and this compatibility
;; function only applies to versions of Emacs before that.
(when handler
(condition-case nil
(funcall handler 'exec-path)
(error nil)))))
((file-remote-p default-directory)
;; TODO: This is not completely portable, even if "sh" and
;; "getconf" should be provided on every POSIX system, the chance
;; of this not working are greater than zero.
;;
;; FIXME: This invokes a shell process every time exec-path is
;; called. It should instead be cached on a host-local basis.
(with-temp-buffer
(if (condition-case nil
(zerop (process-file "sh" nil t nil "-c" "getconf PATH"))
(file-missing t))
(list "/bin" "/usr/bin")
(let (path)
(while (re-search-forward "\\([^:]+?\\)[\n:]" nil t)
(push (match-string 1) path))
(nreverse path)))))
(exec-path)))
(declare-function compat--file-local-name "compat-26"
(file))
;;*UNTESTED
(compat-defun executable-find (command &optional remote)
"Search for COMMAND in `exec-path' and return the absolute file name.
Return nil if COMMAND is not found anywhere in `exec-path'. If
REMOTE is non-nil, search on the remote host indicated by
`default-directory' instead."
:prefix t
(if (and remote (file-remote-p default-directory))
(let ((res (locate-file
command
(mapcar
(apply-partially
#'concat (file-remote-p default-directory))
(compat--exec-path))
exec-suffixes 'file-executable-p)))
(when (stringp res) (compat--file-local-name res)))
(executable-find command)))
;; TODO provide advice for directory-files-recursively
;;;; Defined in format-spec.el
;; TODO provide advice for format-spec
;;;; Defined in regexp-opt.el
(compat-defun regexp-opt (strings &optional paren)
"Handle an empty list of strings."
:prefix t
(if (null strings)
(let ((re "\\`a\\`"))
(cond ((null paren)
(concat "\\(?:" re "\\)"))
((stringp paren)
(concat paren re "\\)"))
((eq paren 'words)
(concat "\\<\\(" re "\\)\\>"))
((eq paren 'symbols)
(concat "\\_\\(<" re "\\)\\_>"))
((concat "\\(" re "\\)"))))
(regexp-opt strings paren)))
;;;; Defined in package.el
(declare-function lm-header "lisp-mnt")
;;* UNTESTED
(compat-defun package-get-version ()
"Return the version number of the package in which this is used.
Assumes it is used from an Elisp file placed inside the top-level directory
of an installed ELPA package.
The return value is a string (or nil in case we can’t find it)."
;; In a sense, this is a lie, but it does just what we want: precompute
;; the version at compile time and hardcodes it into the .elc file!
(declare (pure t))
;; Hack alert!
(let ((file
(or (and (boundp 'byte-compile-current-file) byte-compile-current-file)
load-file-name
buffer-file-name)))
(cond
((null file) nil)
;; Packages are normally installed into directories named "<pkg>-<vers>",
;; so get the version number from there.
((string-match
"/[^/]+-\\([0-9]\\(?:[0-9.]\\|pre\\|beta\\|alpha\\|snapshot\\)+\\)/[^/]+\\'"
file)
(match-string 1 file))
;; For packages run straight from the an elpa.git clone, there's no
;; "-<vers>" in the directory name, so we have to fetch the version
;; the hard way.
((let* ((pkgdir (file-name-directory file))
(pkgname (file-name-nondirectory (directory-file-name pkgdir)))
(mainfile (expand-file-name (concat pkgname ".el") pkgdir)))
(when (file-readable-p mainfile)
(require 'lisp-mnt)
(with-temp-buffer
(insert-file-contents mainfile)
(or (lm-header "package-version")
(lm-header "version")))))))))
;;;; Defined in dired.el
(declare-function
dired-get-marked-files "dired.el"
(&optional localp arg filter distinguish-one-marked error))
;;* UNTESTED
(compat-defun dired-get-marked-files
(&optional localp arg filter distinguish-one-marked error)
"Return the marked files’ names as list of strings."
:feature 'dired
:prefix t
(let ((result (dired-get-marked-files localp arg filter distinguish-one-marked)))
(if (and (null result) error)
(user-error (if (stringp error) error "No files specified"))
result)))
;;;; Defined in time-date.el
(compat-defun date-days-in-month (year month)
"The number of days in MONTH in YEAR."
:feature 'time-date
(unless (and (numberp month)
(<= 1 month)
(<= month 12))
(error "Month %s is invalid" month))
(if (= month 2)
(if (date-leap-year-p year)
29
28)
(if (memq month '(1 3 5 7 8 10 12))
31
30)))
(compat--inhibit-prefixed (provide 'compat-27))
;;; compat-27.el ends here

882
lisp/compat/compat-28.el Normal file
View File

@@ -0,0 +1,882 @@
;;; compat-28.el --- Compatibility Layer for Emacs 28.1 -*- lexical-binding: t; -*-
;; Copyright (C) 2021, 2022 Free Software Foundation, Inc.
;; Author: Philip Kaludercic <philipk@posteo.net>
;; Maintainer: Compat Development <~pkal/compat-devel@lists.sr.ht>
;; URL: https://git.sr.ht/~pkal/compat/
;; Keywords: lisp
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; Find here the functionality added in Emacs 28.1, needed by older
;; versions.
;;
;; Only load this library if you need to use one of the following
;; functions:
;;
;; - `unlock-buffer'
;; - `string-width'
;; - `directory-files'
;; - `json-serialize'
;; - `json-insert'
;; - `json-parse-string'
;; - `json-parse-buffer'
;; - `count-windows'
;;; Code:
(require 'compat-macs "compat-macs.el")
(compat-declare-version "28.1")
;;;; Defined in fns.c
;;* INCOMPLETE FEATURE: Should handle multibyte regular expressions
(compat-defun string-search (needle haystack &optional start-pos)
"Search for the string NEEDLE in the strign HAYSTACK.
The return value is the position of the first occurrence of
NEEDLE in HAYSTACK, or nil if no match was found.
The optional START-POS argument says where to start searching in
HAYSTACK and defaults to zero (start at the beginning).
It must be between zero and the length of HAYSTACK, inclusive.
Case is always significant and text properties are ignored."
:note "Prior to Emacs 27 `string-match' has issues handling
multibyte regular expressions. As the compatibility function
for `string-search' is implemented via `string-match', these
issues are inherited."
(when (and start-pos (or (< (length haystack) start-pos)
(< start-pos 0)))
(signal 'args-out-of-range (list start-pos)))
(save-match-data
(let ((case-fold-search nil))
(string-match (regexp-quote needle) haystack start-pos))))
(compat-defun length= (sequence length)
"Returns non-nil if SEQUENCE has a length equal to LENGTH."
(cond
((null sequence) (zerop length))
((consp sequence)
(and (null (nthcdr length sequence))
(nthcdr (1- length) sequence)
t))
((arrayp sequence)
(= (length sequence) length))
((signal 'wrong-type-argument sequence))))
(compat-defun length< (sequence length)
"Returns non-nil if SEQUENCE is shorter than LENGTH."
(cond
((null sequence) (not (zerop length)))
((listp sequence)
(null (nthcdr (1- length) sequence)))
((arrayp sequence)
(< (length sequence) length))
((signal 'wrong-type-argument sequence))))
(compat-defun length> (sequence length)
"Returns non-nil if SEQUENCE is longer than LENGTH."
(cond
((listp sequence)
(and (nthcdr length sequence) t))
((arrayp sequence)
(> (length sequence) length))
((signal 'wrong-type-argument sequence))))
;;;; Defined in fileio.c
(compat-defun file-name-concat (directory &rest components)
"Append COMPONENTS to DIRECTORY and return the resulting string.
Elements in COMPONENTS must be a string or nil.
DIRECTORY or the non-final elements in COMPONENTS may or may not end
with a slash -- if they don’t end with a slash, a slash will be
inserted before contatenating."
(let ((seperator (eval-when-compile
(if (memq system-type '(ms-dos windows-nt cygwin))
"\\" "/")))
(last (if components (car (last components)) directory)))
(mapconcat (lambda (part)
(if (eq part last) ;the last component is not modified
last
(replace-regexp-in-string
(concat seperator "+\\'") "" part)))
(cons directory components)
seperator)))
;;;; Defined in alloc.c
;;* UNTESTED (but also not necessary)
(compat-defun garbage-collect-maybe (_factor)
"Call ‘garbage-collect’ if enough allocation happened.
FACTOR determines what \"enough\" means here: If FACTOR is a
positive number N, it means to run GC if more than 1/Nth of the
allocations needed to trigger automatic allocation took place.
Therefore, as N gets higher, this is more likely to perform a GC.
Returns non-nil if GC happened, and nil otherwise."
:note "For releases of Emacs before version 28, this function will do nothing."
;; Do nothing
nil)
;;;; Defined in filelock.c
(compat-defun unlock-buffer ()
"Handle `file-error' conditions:
Handles file system errors by calling ‘display-warning’ and
continuing as if the error did not occur."
:prefix t
(condition-case error
(unlock-buffer)
(file-error
(display-warning
'(unlock-file)
(message "%s, ignored" (error-message-string error))
:warning))))
;;;; Defined in characters.c
(compat-defun string-width (string &optional from to)
"Handle optional arguments FROM and TO:
Optional arguments FROM and TO specify the substring of STRING to
consider, and are interpreted as in `substring'."
:prefix t
(let* ((len (length string))
(from (or from 0))
(to (or to len)))
(if (and (= from 0) (= to len))
(string-width string)
(string-width (substring string from to)))))
;;;; Defined in dired.c
;;* UNTESTED
(compat-defun directory-files (directory &optional full match nosort count)
"Handle additional optional argument COUNT:
If COUNT is non-nil and a natural number, the function will
return COUNT number of file names (if so many are present)."
:prefix t
(let ((files (directory-files directory full match nosort)))
(when (natnump count)
(setf (nthcdr count files) nil))
files))
;;;; Defined in json.c
(declare-function json-insert nil (object &rest args))
(declare-function json-serialize nil (object &rest args))
(declare-function json-parse-string nil (string &rest args))
(declare-function json-parse-buffer nil (&rest args))
(compat-defun json-serialize (object &rest args)
"Handle top-level JSON values."
:prefix t
:min-version "27"
(if (or (listp object) (vectorp object))
(apply #'json-serialize object args)
(substring (json-serialize (list object)) 1 -1)))
(compat-defun json-insert (object &rest args)
"Handle top-level JSON values."
:prefix t
:min-version "27"
(if (or (listp object) (vectorp object))
(apply #'json-insert object args)
;; `compat-json-serialize' is not sharp-quoted as the byte
;; compiled doesn't always know that the function has been
;; defined, but it will only be used in this function if the
;; prefixed definition of `json-serialize' (see above) has also
;; been defined.
(insert (apply 'compat-json-serialize object args))))
(compat-defun json-parse-string (string &rest args)
"Handle top-level JSON values."
:prefix t
:min-version "27"
(if (string-match-p "\\`[[:space:]]*[[{]" string)
(apply #'json-parse-string string args)
;; Wrap the string in an array, and extract the value back using
;; `elt', to ensure that no matter what the value of `:array-type'
;; is we can access the first element.
(elt (apply #'json-parse-string (concat "[" string "]") args) 0)))
(compat-defun json-parse-buffer (&rest args)
"Handle top-level JSON values."
:prefix t
:min-version "27"
(if (looking-at-p "[[:space:]]*[[{]")
(apply #'json-parse-buffer args)
(catch 'escape
(atomic-change-group
(with-syntax-table
(let ((st (make-syntax-table)))
(modify-syntax-entry ?\" "\"" st)
(modify-syntax-entry ?. "_" st)
st)
(let ((inhibit-read-only t))
(save-excursion
(insert "[")
(forward-sexp 1)
(insert "]"))))
(throw 'escape (elt (apply #'json-parse-buffer args) 0))))))
;;;; xfaces.c
(compat-defun color-values-from-color-spec (spec)
"Parse color SPEC as a numeric color and return (RED GREEN BLUE).
This function recognises the following formats for SPEC:
#RGB, where R, G and B are hex numbers of equal length, 1-4 digits each.
rgb:R/G/B, where R, G, and B are hex numbers, 1-4 digits each.
rgbi:R/G/B, where R, G and B are floating-point numbers in [0,1].
If SPEC is not in one of the above forms, return nil.
Each of the 3 integer members of the resulting list, RED, GREEN,
and BLUE, is normalized to have its value in [0,65535]."
(let ((case-fold-search nil))
(save-match-data
(cond
((string-match
;; (rx bos "#"
;; (or (: (group-n 1 (= 1 hex)) (group-n 2 (= 1 hex)) (group-n 3 (= 1 hex)))
;; (: (group-n 1 (= 2 hex)) (group-n 2 (= 2 hex)) (group-n 3 (= 2 hex)))
;; (: (group-n 1 (= 3 hex)) (group-n 2 (= 3 hex)) (group-n 3 (= 3 hex)))
;; (: (group-n 1 (= 4 hex)) (group-n 2 (= 4 hex)) (group-n 3 (= 4 hex))))
;; eos)
"\\`#\\(?:\\(?1:[[:xdigit:]]\\{1\\}\\)\\(?2:[[:xdigit:]]\\{1\\}\\)\\(?3:[[:xdigit:]]\\{1\\}\\)\\|\\(?1:[[:xdigit:]]\\{2\\}\\)\\(?2:[[:xdigit:]]\\{2\\}\\)\\(?3:[[:xdigit:]]\\{2\\}\\)\\|\\(?1:[[:xdigit:]]\\{3\\}\\)\\(?2:[[:xdigit:]]\\{3\\}\\)\\(?3:[[:xdigit:]]\\{3\\}\\)\\|\\(?1:[[:xdigit:]]\\{4\\}\\)\\(?2:[[:xdigit:]]\\{4\\}\\)\\(?3:[[:xdigit:]]\\{4\\}\\)\\)\\'"
spec)
(let ((max (1- (ash 1 (* (- (match-end 1) (match-beginning 1)) 4)))))
(list (/ (* (string-to-number (match-string 1 spec) 16) 65535) max)
(/ (* (string-to-number (match-string 2 spec) 16) 65535) max)
(/ (* (string-to-number (match-string 3 spec) 16) 65535) max))))
((string-match
;; (rx bos "rgb:"
;; (group (** 1 4 hex)) "/"
;; (group (** 1 4 hex)) "/"
;; (group (** 1 4 hex))
;; eos)
"\\`rgb:\\([[:xdigit:]]\\{1,4\\}\\)/\\([[:xdigit:]]\\{1,4\\}\\)/\\([[:xdigit:]]\\{1,4\\}\\)\\'"
spec)
(list (/ (* (string-to-number (match-string 1 spec) 16) 65535)
(1- (ash 1 (* (- (match-end 1) (match-beginning 1)) 4))))
(/ (* (string-to-number (match-string 2 spec) 16) 65535)
(1- (ash 1 (* (- (match-end 2) (match-beginning 2)) 4))))
(/ (* (string-to-number (match-string 3 spec) 16) 65535)
(1- (ash 1 (* (- (match-end 3) (match-beginning 3)) 4))))))
;; The "RGBi" (RGB Intensity) specification is defined by
;; XCMS[0], see [1] for the implementation in Xlib.
;;
;; [0] http://www.nic.funet.fi/pub/X11/X11R4/DOCS/color/Xcms.text
;; [1] https://gitlab.freedesktop.org/xorg/lib/libx11/-/blob/master/src/xcms/LRGB.c#L1392
((string-match
;; (rx bos "rgbi:" (* space)
;; (group (? (or "-" "+"))
;; (or (: (+ digit) (? "." (* digit)))
;; (: "." (+ digit)))
;; (? "e" (? (or "-" "+")) (+ digit)))
;; "/" (* space)
;; (group (? (or "-" "+"))
;; (or (: (+ digit) (? "." (* digit)))
;; (: "." (+ digit)))
;; (? "e" (? (or "-" "+")) (+ digit)))
;; "/" (* space)
;; (group (? (or "-" "+"))
;; (or (: (+ digit) (? "." (* digit)))
;; (: "." (+ digit)))
;; (? "e" (? (or "-" "+")) (+ digit)))
;; eos)
"\\`rgbi:[[:space:]]*\\([+-]?\\(?:[[:digit:]]+\\(?:\\.[[:digit:]]*\\)?\\|\\.[[:digit:]]+\\)\\(?:e[+-]?[[:digit:]]+\\)?\\)/[[:space:]]*\\([+-]?\\(?:[[:digit:]]+\\(?:\\.[[:digit:]]*\\)?\\|\\.[[:digit:]]+\\)\\(?:e[+-]?[[:digit:]]+\\)?\\)/[[:space:]]*\\([+-]?\\(?:[[:digit:]]+\\(?:\\.[[:digit:]]*\\)?\\|\\.[[:digit:]]+\\)\\(?:e[+-]?[[:digit:]]+\\)?\\)\\'"
spec)
(let ((r (round (* (string-to-number (match-string 1 spec)) 65535)))
(g (round (* (string-to-number (match-string 2 spec)) 65535)))
(b (round (* (string-to-number (match-string 3 spec)) 65535))))
(when (and (<= 0 r) (<= r 65535)
(<= 0 g) (<= g 65535)
(<= 0 b) (<= b 65535))
(list r g b))))))))
;;;; Defined in subr.el
;;* INCOMPLETE FEATURE: Should handle multibyte regular expressions
(compat-defun string-replace (fromstring tostring instring)
"Replace FROMSTRING with TOSTRING in INSTRING each time it occurs."
(when (equal fromstring "")
(signal 'wrong-length-argument '(0)))
(let ((case-fold-search nil))
(replace-regexp-in-string
(regexp-quote fromstring)
tostring instring
t t)))
(compat-defun always (&rest _arguments)
"Do nothing and return t.
This function accepts any number of ARGUMENTS, but ignores them.
Also see `ignore'."
t)
;;* UNTESTED
(compat-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))))
;;* UNTESTED
(compat-defun replace-string-in-region (string replacement &optional start end)
"Replace STRING with REPLACEMENT in the region from START to END.
The number of replaced occurrences are returned, or nil if STRING
doesn't exist in the region.
If START is nil, use the current point. If END is nil, use `point-max'.
Comparisons and replacements are done with fixed case."
(if start
(when (< start (point-min))
(error "Start before start of buffer"))
(setq start (point)))
(if end
(when (> end (point-max))
(error "End after end of buffer"))
(setq end (point-max)))
(save-excursion
(let ((matches 0)
(case-fold-search nil))
(goto-char start)
(while (search-forward string end t)
(delete-region (match-beginning 0) (match-end 0))
(insert replacement)
(setq matches (1+ matches)))
(and (not (zerop matches))
matches))))
;;* UNTESTED
(compat-defun replace-regexp-in-region (regexp replacement &optional start end)
"Replace REGEXP with REPLACEMENT in the region from START to END.
The number of replaced occurrences are returned, or nil if REGEXP
doesn't exist in the region.
If START is nil, use the current point. If END is nil, use `point-max'.
Comparisons and replacements are done with fixed case.
REPLACEMENT can use the following special elements:
`\\&' in NEWTEXT means substitute original matched text.
`\\N' means substitute what matched the Nth `\\(...\\)'.
If Nth parens didn't match, substitute nothing.
`\\\\' means insert one `\\'.
`\\?' is treated literally."
(if start
(when (< start (point-min))
(error "Start before start of buffer"))
(setq start (point)))
(if end
(when (> end (point-max))
(error "End after end of buffer"))
(setq end (point-max)))
(save-excursion
(let ((matches 0)
(case-fold-search nil))
(goto-char start)
(while (re-search-forward regexp end t)
(replace-match replacement t)
(setq matches (1+ matches)))
(and (not (zerop matches))
matches))))
;;* UNTESTED
(compat-defun buffer-local-boundp (symbol buffer)
"Return non-nil if SYMBOL is bound in BUFFER.
Also see `local-variable-p'."
(catch 'fail
(condition-case nil
(buffer-local-value symbol buffer)
(void-variable nil (throw 'fail nil)))
t))
;;* UNTESTED
(compat-defmacro with-existing-directory (&rest body)
"Execute BODY with `default-directory' bound to an existing directory.
If `default-directory' is already an existing directory, it's not changed."
(declare (indent 0) (debug t))
(let ((quit (make-symbol "with-existing-directory-quit")))
`(catch ',quit
(dolist (dir (list default-directory
(expand-file-name "~/")
(getenv "TMPDIR")
"/tmp/"
;; XXX: check if "/" works on non-POSIX
;; system.
"/"))
(when (and dir (file-exists-p dir))
(throw ',quit (let ((default-directory dir))
,@body)))))))
;;* UNTESTED
(compat-defmacro dlet (binders &rest body)
"Like `let' but using dynamic scoping."
(declare (indent 1) (debug let))
`(let (_)
,@(mapcar (lambda (binder)
`(defvar ,(if (consp binder) (car binder) binder)))
binders)
(let ,binders ,@body)))
(compat-defun ensure-list (object)
"Return OBJECT as a list.
If OBJECT is already a list, return OBJECT itself. If it's
not a list, return a one-element list containing OBJECT."
(if (listp object)
object
(list object)))
(compat-defun subr-primitive-p (object)
"Return t if OBJECT is a built-in primitive function."
(subrp object))
;;;; Defined in subr-x.el
(compat-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."
:feature 'subr-x
(let ((blank "[[:blank:]\r\n]+"))
(replace-regexp-in-string
"^[[:blank:]\r\n]+\\|[[:blank:]\r\n]+$"
""
(replace-regexp-in-string
blank " " string))))
(compat-defun string-fill (string length)
"Clean up whitespace in STRING.
All sequences of whitespaces in STRING are collapsed into a
single space character, and leading/trailing whitespace is
removed."
:feature 'subr-x
(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)))
(compat-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."
:feature 'subr-x
(split-string string "\n" omit-nulls))
(compat-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."
:feature 'subr-x
(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)))))))
(compat-defun string-chop-newline (string)
"Remove the final newline (if any) from STRING."
:feature 'subr-x
(if (and (>= (length string) 1) (= (aref string (1- (length string))) ?\n))
(substring string 0 -1)
string))
(compat-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."
:feature 'subr-x
(declare (indent 2) (debug (symbolp (&rest (symbolp form)) body)))
(let ((fargs (mapcar (lambda (b)
(let ((var (if (consp b) (car b) b)))
(make-symbol (symbol-name var))))
bindings))
(aargs (mapcar (lambda (b) (if (consp b) (cadr b))) bindings))
rargs)
(dotimes (i (length bindings))
(let ((b (nth i bindings)))
(push (list (if (consp b) (car b) b) (nth i fargs))
rargs)
(setf (if (consp b) (car b) b)
(nth i fargs))))
(letrec
((quit (make-symbol "quit")) (self (make-symbol "self"))
(total-tco t)
(macro (lambda (&rest args)
(setq total-tco nil)
`(funcall ,self . ,args)))
;; Based on `cl--self-tco':
(tco-progn (lambda (exprs)
(append
(butlast exprs)
(list (funcall tco (car (last exprs)))))))
(tco (lambda (expr)
(cond
((eq (car-safe expr) 'if)
(append (list 'if
(cadr expr)
(funcall tco (nth 2 expr)))
(funcall tco-progn (nthcdr 3 expr))))
((eq (car-safe expr) 'cond)
(let ((conds (cdr expr)) body)
(while conds
(let ((branch (pop conds)))
(push (cond
((cdr branch) ;has tail
(funcall tco-progn branch))
((null conds) ;last element
(list t (funcall tco (car branch))))
((progn
branch)))
body)))
(cons 'cond (nreverse body))))
((eq (car-safe expr) 'or)
(if (cddr expr)
(let ((var (make-symbol "var")))
`(let ((,var ,(cadr expr)))
(if ,var ,(funcall tco var)
,(funcall tco (cons 'or (cddr expr))))))
(funcall tco (cadr expr))))
((eq (car-safe expr) 'condition-case)
(append (list 'condition-case (cadr expr) (nth 2 expr))
(mapcar
(lambda (handler)
(cons (car handler)
(funcall tco-progn (cdr handler))))
(nthcdr 3 expr))))
((memq (car-safe expr) '(and progn))
(cons (car expr) (funcall tco-progn (cdr expr))))
((memq (car-safe expr) '(let let*))
(append (list (car expr) (cadr expr))
(funcall tco-progn (cddr expr))))
((eq (car-safe expr) name)
(let (sets (args (cdr expr)))
(dolist (farg fargs)
(push (list farg (pop args))
sets))
(cons 'setq (apply #'nconc (nreverse sets)))))
(`(throw ',quit ,expr))))))
(let ((tco-body (funcall tco (macroexpand-all (macroexp-progn body)))))
(when tco-body
(setq body `((catch ',quit
(while t (let ,rargs ,@(macroexp-unprogn tco-body))))))))
(let ((expand (macroexpand-all (macroexp-progn body) (list (cons name macro)))))
(if total-tco
`(let ,bindings ,expand)
`(funcall
(letrec ((,self (lambda ,fargs ,expand))) ,self)
,@aargs))))))
;;;; Defined in files.el
(declare-function compat--string-trim-left "compat-26" (string &optional regexp))
(declare-function compat--directory-name-p "compat-25" (name))
(compat-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 (compat--string-trim-left extension "[.]")))
(cond
((string= filename "")
(error "Empty filename"))
((string= extn "")
(error "Malformed extension: %s" extension))
((compat--directory-name-p filename)
(error "Filename is a directory: %s" filename))
(t
(concat (file-name-sans-extension filename) "." extn)))))
;;* UNTESTED
(compat-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))))
(compat-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))))
;;* UNTESTED
(compat-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))))
(dir (file-name-directory filename))
files)
(dolist (file (file-name-all-completions
(file-name-nondirectory filename) dir))
(let ((candidate (concat dir file)))
(when (and (backup-file-name-p candidate)
(string= (file-name-sans-versions candidate) filename))
(push candidate files))))
(sort files #'file-newer-than-file-p)))
(compat-defun make-lock-file-name (filename)
"Make a lock file name for FILENAME.
This prepends \".#\" to the non-directory part of FILENAME, and
doesn't respect `lock-file-name-transforms', as Emacs 28.1 and
onwards does."
(expand-file-name
(concat
".#" (file-name-nondirectory filename))
(file-name-directory filename)))
;;;; Defined in files-x.el
(declare-function tramp-tramp-file-p "tramp" (name))
;;* UNTESTED
(compat-defun null-device ()
"Return the best guess for the null device."
(require 'tramp)
(if (tramp-tramp-file-p default-directory)
"/dev/null"
null-device))
;;;; Defined in minibuffer.el
(compat-defun format-prompt (prompt default &rest format-args)
"Format PROMPT with DEFAULT.
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 " (default %s)"
(if (consp default)
(car default)
default)))
": "))
;;;; Defined in windows.el
;;* UNTESTED
(compat-defun count-windows (&optional minibuf all-frames)
"Handle optional argument ALL-FRAMES:
If ALL-FRAMES is non-nil, count the windows in all frames instead
just the selected frame."
:prefix t
(if all-frames
(let ((sum 0))
(dolist (frame (frame-list))
(with-selected-frame frame
(setq sum (+ (count-windows minibuf) sum))))
sum)
(count-windows minibuf)))
;;;; Defined in thingatpt.el
(declare-function mouse-set-point "mouse" (event &optional promote-to-region))
;;* UNTESTED
(compat-defun thing-at-mouse (event thing &optional no-properties)
"Return the THING at mouse click.
Like `thing-at-point', but tries to use the event
where the mouse button is clicked to find a thing nearby."
:feature 'thingatpt
(save-excursion
(mouse-set-point event)
(thing-at-point thing no-properties)))
;;;; Defined in macroexp.el
;;* UNTESTED
(compat-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."
:feature 'macroexp
(let ((file (car (last current-load-list))))
(or (if (stringp file) file)
(bound-and-true-p byte-compile-current-file))))
;;;; Defined in env.el
;;* UNTESTED
(compat-defmacro with-environment-variables (variables &rest body)
"Set VARIABLES in the environent and execute BODY.
VARIABLES is a list of variable settings of the form (VAR VALUE),
where VAR is the name of the variable (a string) and VALUE
is its value (also a string).
The previous values will be be restored upon exit."
(declare (indent 1) (debug (sexp body)))
(unless (consp variables)
(error "Invalid VARIABLES: %s" variables))
`(let ((process-environment (copy-sequence process-environment)))
,@(mapcar (lambda (elem)
`(setenv ,(car elem) ,(cadr elem)))
variables)
,@body))
;;;; Defined in button.el
;;* UNTESTED
(compat-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."
:feature 'button
(propertize string
'face 'button
'button t
'follow-link t
'category t
'button-data data
'keymap button-map
'action callback))
;;;; Defined in autoload.el
(defvar generated-autoload-file)
;;* UNTESTED
(compat-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."
(let ((generated-autoload-file output-file))
;; We intentionally don't sharp-quote
;; `update-directory-autoloads', because it was deprecated in
;; Emacs 28 and we don't want to trigger the byte compiler for
;; newer versions.
(apply 'update-directory-autoloads
(if (listp dir) dir (list dir)))))
;;;; Defined in time-data.el
(compat-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."
:feature 'time-date
:version "28"
;; Inlining the definitions from compat-27
(+ (if (consp (nth 0 time))
;; Fractional second.
(/ (float (car (nth 0 time)))
(cdr (nth 0 time)))
(or (nth 0 time) 0))
(* (or (nth 1 time) 0) 60)
(* (or (nth 2 time) 0) 60 60)
(* (or (nth 3 time) 0) 60 60 24)
(* (or (nth 4 time) 0) 60 60 24 30)
(* (or (nth 5 time) 0) 60 60 24 365)))
(compat--inhibit-prefixed (provide 'compat-28))
;;; compat-28.el ends here

48
lisp/compat/compat-font-lock.el Normal file
View File

@@ -0,0 +1,48 @@
;;; compat-font-lock.el --- -*- lexical-binding: t; -*-
;; Copyright (C) 2022 Free Software Foundation, Inc.
;; Author: Philip Kaludercic <philipk@posteo.net>
;; Keywords:
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; Optional font-locking for `compat' definitions. Every symbol with
;; an active compatibility definition will be highlighted.
;;
;; Load this file to enable the functionality.
;;; Code:
(eval-and-compile
(require 'cl-lib)
(require 'compat-macs))
(defvar compat-generate-common-fn)
(let ((compat-generate-common-fn
(lambda (name _def-fn _install-fn check-fn attr _type)
(unless (and (plist-get attr :no-highlight)
(funcall check-fn))
`(font-lock-add-keywords
'emacs-lisp-mode
',`((,(concat "\\_<\\("
(regexp-quote (symbol-name name))
"\\)\\_>")
1 font-lock-preprocessor-face prepend)))))))
(load "compat"))
(provide 'compat-font-lock)
;;; compat-font-lock.el ends here

57
lisp/compat/compat-help.el Normal file
View File

@@ -0,0 +1,57 @@
;;; compat-help.el --- Documentation for compat functions -*- lexical-binding: t; -*-
;; Copyright (C) 2022 Free Software Foundation, Inc.
;; Author: Philip Kaludercic <philipk@posteo.net>
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; Load this file to insert `compat'-relevant documentation next to
;; the regular documentation of a symbol.
;;; Code:
(defun compat---describe (symbol)
"Insert documentation for SYMBOL if it has compatibility code."
(let ((compat (get symbol 'compat-def)))
(when compat
(let ((doc (get compat 'compat-doc))
(start (point)))
(when doc
(insert "There is a ")
(insert-button
"compatibility notice"
'action (let ((type (get compat 'compat-type)))
(cond
((memq type '(func macro advice))
#'find-function)
((memq type '(variable))
#'find-variable)
((error "Unknown type"))))
'button-data compat)
(insert (format " for %s (for versions of Emacs before %s):"
(symbol-name symbol)
(get compat 'compat-version)))
(add-text-properties start (point) '(face bold))
(newline 2)
(insert (substitute-command-keys doc))
(fill-region start (point))
(newline 2))))))
(add-hook 'help-fns-describe-function-functions #'compat---describe)
(provide 'compat-help)
;;; compat-help.el ends here

316
lisp/compat/compat-macs.el Normal file
View File

@@ -0,0 +1,316 @@
;;; compat-macs.el --- Compatibility Macros -*- lexical-binding: t; no-byte-compile: t; -*-
;; Copyright (C) 2021, 2022 Free Software Foundation, Inc.
;; Author: Philip Kaludercic <philipk@posteo.net>
;; Keywords: lisp
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; These macros are used to define compatibility functions, macros and
;; advice.
;;; Code:
(defmacro compat--ignore (&rest _)
"Ignore all arguments."
nil)
(defvar compat--inhibit-prefixed nil
"Non-nil means that prefixed definitions are not loaded.
A prefixed function is something like `compat-assoc', that is
only made visible when the respective compatibility version file
is loaded (in this case `compat-26').")
(defmacro compat--inhibit-prefixed (&rest body)
"Ignore BODY unless `compat--inhibit-prefixed' is true."
`(unless (bound-and-true-p compat--inhibit-prefixed)
,@body))
(defvar compat-current-version nil
"Default version to use when no explicit version was given.")
(defmacro compat-declare-version (version)
"Set the Emacs version that is currently being handled to VERSION."
;; FIXME: Avoid setting the version for any definition that might
;; follow, but try to restrict it to the current file/buffer.
(setq compat-current-version version)
nil)
(defvar compat--generate-function #'compat--generate-default
"Function used to generate compatibility code.
The function must take six arguments: NAME, DEF-FN, INSTALL-FN,
CHECK-FN, ATTR and TYPE. The resulting body is constructed by
invoking the functions DEF-FN (passed the \"realname\" and the
version number, returning the compatibility definition), the
INSTALL-FN (passed the \"realname\" and returning the
installation code), CHECK-FN (passed the \"realname\" and
returning a check to see if the compatibility definition should
be installed). ATTR is a plist used to modify the generated
code. The following attributes are handled, all others are
ignored:
- :min-version :: Prevent the compatibility definition from begin
installed in versions older than indicated (string).
- :max-version :: Prevent the compatibility definition from begin
installed in versions newer than indicated (string).
- :feature :: The library the code is supposed to be loaded
with (via `eval-after-load').
- :cond :: Only install the compatibility code, iff the value
evaluates to non-nil.
For prefixed functions, this can be interpreted as a test to
`defalias' an existing definition or not.
- :no-highlight :: Do not highlight this definition as
compatibility function.
- :version :: Manual specification of the version the compatee
code was defined in (string).
- :realname :: Manual specification of a \"realname\" to use for
the compatibility definition (symbol).
- :notes :: Additional notes that a developer using this
compatibility function should keep in mind.
- :prefix :: Add a `compat-' prefix to the name, and define the
compatibility code unconditionally.
TYPE is used to set the symbol property `compat-type' for NAME.")
(defun compat--generate-default (name def-fn install-fn check-fn attr type)
"Generate a leaner compatibility definition.
See `compat-generate-function' for details on the arguments NAME,
DEF-FN, INSTALL-FN, CHECK-FN, ATTR and TYPE."
(let* ((min-version (plist-get attr :min-version))
(max-version (plist-get attr :max-version))
(feature (plist-get attr :feature))
(cond (plist-get attr :cond))
(version (or (plist-get attr :version)
compat-current-version))
(realname (or (plist-get attr :realname)
(intern (format "compat--%S" name))))
(check (cond
((or (and min-version
(version< emacs-version min-version))
(and max-version
(version< max-version emacs-version)))
'(compat--ignore))
((plist-get attr :prefix)
'(compat--inhibit-prefixed))
((and version (version<= version emacs-version) (not cond))
'(compat--ignore))
(`(when (and ,(if cond cond t)
,(funcall check-fn)))))))
(cond
((and (plist-get attr :prefix) (memq type '(func macro))
(string-match "\\`compat-\\(.+\\)\\'" (symbol-name name))
(let* ((actual-name (intern (match-string 1 (symbol-name name))))
(body (funcall install-fn actual-name version)))
(when (and (version<= version emacs-version)
(fboundp actual-name))
`(,@check
,(if feature
;; See https://nullprogram.com/blog/2018/02/22/:
`(eval-after-load ,feature `(funcall ',(lambda () ,body)))
body))))))
((plist-get attr :realname)
`(progn
,(funcall def-fn realname version)
(,@check
,(let ((body (funcall install-fn realname version)))
(if feature
;; See https://nullprogram.com/blog/2018/02/22/:
`(eval-after-load ,feature `(funcall ',(lambda () ,body)))
body)))))
((let* ((body (if (eq type 'advice)
`(,@check
,(funcall def-fn realname version)
,(funcall install-fn realname version))
`(,@check ,(funcall def-fn name version)))))
(if feature
;; See https://nullprogram.com/blog/2018/02/22/:
`(eval-after-load ,feature `(funcall ',(lambda () ,body)))
body))))))
(defun compat-generate-common (name def-fn install-fn check-fn attr type)
"Common code for generating compatibility definitions.
See `compat-generate-function' for details on the arguments NAME,
DEF-FN, INSTALL-FN, CHECK-FN, ATTR and TYPE."
(when (and (plist-get attr :cond) (plist-get attr :prefix))
(error "A prefixed function %s cannot have a condition" name))
(funcall compat--generate-function
name def-fn install-fn check-fn attr type))
(defun compat-common-fdefine (type name arglist docstring rest)
"Generate compatibility code for a function NAME.
TYPE is one of `func', for functions and `macro' for macros, and
`advice' ARGLIST is passed on directly to the definition, and
DOCSTRING is prepended with a compatibility note. REST contains
the remaining definition, that may begin with a property list of
attributes (see `compat-generate-common')."
(let ((oldname name) (body rest))
(while (keywordp (car body))
(setq body (cddr body)))
;; It might be possible to set these properties otherwise. That
;; should be looked into and implemented if it is the case.
(when (and (listp (car-safe body)) (eq (caar body) 'declare))
(when (version<= emacs-version "25")
(delq (assq 'side-effect-free (car body)) (car body))
(delq (assq 'pure (car body)) (car body))))
;; Check if we want an explicitly prefixed function
(when (plist-get rest :prefix)
(setq name (intern (format "compat-%s" name))))
(compat-generate-common
name
(lambda (realname version)
`(,(cond
((memq type '(func advice)) 'defun)
((eq type 'macro) 'defmacro)
((error "Unknown type")))
,realname ,arglist
;; Prepend compatibility notice to the actual
;; documentation string.
,(let ((type (cond
((eq type 'func) "function")
((eq type 'macro) "macro")
((eq type 'advice) "advice")
((error "Unknown type")))))
(if version
(format
"[Compatibility %s for `%S', defined in Emacs %s]\n\n%s"
type oldname version docstring)
(format
"[Compatibility %s for `%S']\n\n%s"
type oldname docstring)))
;; Advice may use the implicit variable `oldfun', but
;; to avoid triggering the byte compiler, we make
;; sure the argument is used at least once.
,@(if (eq type 'advice)
(cons '(ignore oldfun) body)
body)))
(lambda (realname _version)
(cond
((memq type '(func macro))
;; Functions and macros are installed by
;; aliasing the name of the compatible
;; function to the name of the compatibility
;; function.
`(defalias ',name #',realname))
((eq type 'advice)
`(advice-add ',name :around #',realname))))
(lambda ()
(cond
((memq type '(func macro))
`(not (fboundp ',name)))
((eq type 'advice) t)))
rest type)))
(defmacro compat-defun (name arglist docstring &rest rest)
"Define NAME with arguments ARGLIST as a compatibility function.
The function must be documented in DOCSTRING. REST may begin
with a plist, that is interpreted by the macro but not passed on
to the actual function. See `compat-generate-common' for a
listing of attributes.
The definition will only be installed, if the version this
function was defined in, as indicated by the `:version'
attribute, is greater than the current Emacs version."
(declare (debug (&define name (&rest symbolp)
stringp
[&rest keywordp sexp]
def-body))
(doc-string 3) (indent 2))
(compat-common-fdefine 'func name arglist docstring rest))
(defmacro compat-defmacro (name arglist docstring &rest rest)
"Define NAME with arguments ARGLIST as a compatibility macro.
The macro must be documented in DOCSTRING. REST may begin
with a plist, that is interpreted by this macro but not passed on
to the actual macro. See `compat-generate-common' for a
listing of attributes.
The definition will only be installed, if the version this
function was defined in, as indicated by the `:version'
attribute, is greater than the current Emacs version."
(declare (debug compat-defun) (doc-string 3) (indent 2))
(compat-common-fdefine 'macro name arglist docstring rest))
(defmacro compat-advise (name arglist docstring &rest rest)
"Define NAME with arguments ARGLIST as a compatibility advice.
The advice function must be documented in DOCSTRING. REST may
begin with a plist, that is interpreted by this macro but not
passed on to the actual advice function. See
`compat-generate-common' for a listing of attributes. The advice
wraps the old definition, that is accessible via using the symbol
`oldfun'.
The advice will only be installed, if the version this function
was defined in, as indicated by the `:version' attribute, is
greater than the current Emacs version."
(declare (debug compat-defun) (doc-string 3) (indent 2))
(compat-common-fdefine 'advice name (cons 'oldfun arglist) docstring rest))
(defmacro compat-defvar (name initval docstring &rest attr)
"Declare compatibility variable NAME with initial value INITVAL.
The obligatory documentation string DOCSTRING must be given.
The remaining arguments ATTR form a plist, modifying the
behaviour of this macro. See `compat-generate-common' for a
listing of attributes. Furthermore, `compat-defvar' also handles
the attribute `:local' that either makes the variable permanent
local with a value of `permanent' or just buffer local with any
non-nil value."
(declare (debug (name form stringp [&rest keywordp sexp]))
(doc-string 3) (indent 2))
;; Check if we want an explicitly prefixed function
(let ((oldname name))
(when (plist-get attr :prefix)
(setq name (intern (format "compat-%s" name))))
(compat-generate-common
name
(lambda (realname version)
(let ((localp (plist-get attr :local)))
`(progn
(,(if (plist-get attr :constant) 'defconst 'defvar)
,realname ,initval
;; Prepend compatibility notice to the actual
;; documentation string.
,(if version
(format
"[Compatibility variable for `%S', defined in Emacs %s]\n\n%s"
oldname version docstring)
(format
"[Compatibility variable for `%S']\n\n%s"
oldname docstring)))
;; Make variable as local if necessary
,(cond
((eq localp 'permanent)
`(put ',realname 'permanent-local t))
(localp
`(make-variable-buffer-local ',realname))))))
(lambda (realname _version)
`(defvaralias ',name ',realname))
(lambda ()
`(not (boundp ',name)))
attr 'variable)))
(provide 'compat-macs)
;;; compat-macs.el ends here

Some files were not shown because too many files have changed in this diff Show More