procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge commit '107ce3050fc37b9a13d8304ae1bb73fac9de5f61'

Browse source
This commit is contained in:
Stephen Leake 2019-09-18 17:43:28 -07:00
commit 34f1035e87
104 changed files with 2182 additions and 1366 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

103
admin/nt/dist-build/build-dep-zips.py
View file

@ -28,13 +28,33 @@
## Constants
EMACS_MAJOR_VERSION="27"
# This list derives from the features we want Emacs to compile with.
PKG_REQ='''mingw-w64-x86_64-giflib
mingw-w64-x86_64-gnutls
mingw-w64-x86_64-lcms2
mingw-w64-x86_64-libjpeg-turbo
mingw-w64-x86_64-libpng
mingw-w64-x86_64-librsvg
mingw-w64-x86_64-libtiff
mingw-w64-x86_64-libxml2
mingw-w64-x86_64-xpm-nox'''.split()
## Options
DRY_RUN=False
## Packages to fiddle with
SKIP_PKGS=["mingw-w64-gcc-libs"]
MUNGE_PKGS ={"mingw-w64-libwinpthread-git":"mingw-w64-winpthreads-git"}
## Source for gcc-libs is part of gcc
SKIP_SRC_PKGS=["mingw-w64-gcc-libs"]
SKIP_DEP_PKGS=["mingw-w64-x86_64-glib2"]
MUNGE_SRC_PKGS={"mingw-w64-libwinpthread-git":"mingw-w64-winpthreads-git"}
MUNGE_DEP_PKGS={
"mingw-w64-i686-libwinpthread":"mingw-w64-i686-libwinpthread-git",
"mingw-w64-x86_64-libwinpthread":"mingw-w64-x86_64-libwinpthread-git",
"mingw-w64-x86_64-libtre": "mingw-w64-x86_64-libtre-git",
"mingw-w64-i686-libtre": "mingw-w64-i686-libtre-git"
}
## Currently no packages seem to require this!
ARCH_PKGS=[]
@ -47,28 +67,40 @@ def check_output_maybe(*args,**kwargs):
else:
return check_output(*args,**kwargs)
def immediate_deps(pkg):
package_info = check_output(["pacman", "-Si", pkg]).decode("utf-8").split("\n")
## Extract the "Depends On" line
depends_on = [x for x in package_info if x.startswith("Depends On")][0]
## Remove "Depends On" prefix
dependencies = depends_on.split(":")[1]
## Split into dependencies
dependencies = dependencies.strip().split(" ")
## Remove > signs TODO can we get any other punctation here?
dependencies = [d.split(">")[0] for d in dependencies if d]
dependencies = [d for d in dependencies if not d == "None"]
dependencies = [MUNGE_DEP_PKGS.get(d, d) for d in dependencies]
return dependencies
def extract_deps():
print( "Extracting deps" )
# This list derives from the features we want Emacs to compile with.
PKG_REQ='''mingw-w64-x86_64-giflib
mingw-w64-x86_64-gnutls
mingw-w64-x86_64-harfbuzz
mingw-w64-x86_64-lcms2
mingw-w64-x86_64-libjpeg-turbo
mingw-w64-x86_64-libpng
mingw-w64-x86_64-librsvg
mingw-w64-x86_64-libtiff
mingw-w64-x86_64-libxml2
mingw-w64-x86_64-xpm-nox'''.split()
# Get a list of all dependencies needed for packages mentioned above.
# Run `pactree -lu' for each element of $PKG_REQ.
pkgs = set()
for x in PKG_REQ:
pkgs.update(
check_output(["pactree", "-lu", x]).decode("utf-8").split()
)
pkgs = PKG_REQ[:]
print("Initial pkgs", pkgs)
n = 0
while n < len(pkgs):
subdeps = immediate_deps(pkgs[n])
for p in subdeps:
if not (p in pkgs or p in SKIP_DEP_PKGS):
print("adding", p)
pkgs.append(p)
n = n + 1
return sorted(pkgs)
@ -112,13 +144,20 @@ def gather_deps(deps, arch, directory):
def download_source(tarball):
print("Downloading {}...".format(tarball))
check_output_maybe(
"wget -a ../download.log -O {} {}/{}/download"
.format(tarball, SRC_REPO, tarball),
shell=True
)
print("Downloading {}... done".format(tarball))
print("Acquiring {}...".format(tarball))
if os.path.exists("../emacs-src-cache/{}".format(tarball)):
print("Copying {} from local".format(tarball))
shutil.copyfile("../emacs-src-cache/{}".format(tarball),
"{}".format(tarball))
else:
print("Downloading {}...".format(tarball))
check_output_maybe(
"wget -a ../download.log -O {} {}/{}/download"
.format(tarball, SRC_REPO, tarball),
shell=True
)
print("Downloading {}... done".format(tarball))
def gather_source(deps):
@ -146,7 +185,7 @@ def gather_source(deps):
## make a simple name to make lookup easier
simple_pkg_name = re.sub(r"x86_64-","",pkg_name)
if(simple_pkg_name in SKIP_PKGS):
if(simple_pkg_name in SKIP_SRC_PKGS):
continue
## Some packages have different source files for different
@ -159,7 +198,7 @@ def gather_source(deps):
for d in downloads:
## Switch names if necessary
d = MUNGE_PKGS.get(d,d)
d = MUNGE_SRC_PKGS.get(d,d)
tarball = "{}-{}.src.tar.gz".format(d,pkg_version)
@ -209,6 +248,9 @@ def clean():
parser.add_argument("-d", help="dry run",
action="store_true")
parser.add_argument("-l", help="list dependencies only",
action="store_true")
args = parser.parse_args()
do_all=not (args.c or args.r or args.f or args.t)
@ -216,6 +258,11 @@ def clean():
DRY_RUN=args.d
if( args.l ):
print("List of dependencies")
print( extract_deps() )
exit(0)
if args.s:
DATE="{}-".format(check_output(["date", "+%Y-%m-%d"]).decode("utf-8").strip())
else:

6
admin/upload-manuals
View file

@ -87,6 +87,9 @@ OPTIND=1
[ $# -eq 1 ] || usage
[ -e html_mono/emacs.html ] && [ -e html_node/emacs/index.html ] || \
die "Current directory does not look like the manual/ directory"
[ "$version$umessage" ] || \
die "Could not get version to use for commit message"
@ -95,9 +98,6 @@ webdir=$1
[ -e $webdir/CVS/Entries ] && [ -e $webdir/refcards/pdf/refcard.pdf ] || \
die "$webdir does not look like a checkout of the Emacs webpages"
[ -e html_mono/emacs.html ] && [ -e html_node/emacs/index.html ] || \
die "Current directory does not like the manual/ directory"
echo "Doing refcards..."

6
doc/emacs/maintaining.texi
View file

@ -1281,6 +1281,12 @@ point is on a directory entry, mark all files in that directory tree
(@code{vc-dir-mark-all-files}). With a prefix argument, mark all
listed files and directories.
@item G
Add the file under point to the list of files that the VC should
ignore (@code{vc-dir-ignore}). For instance, if the VC is Git, it
will append this file to the @file{.gitignore} file. If given a
prefix, do this with all the marked files.
@item q
Quit the VC Directory buffer, and bury it (@code{quit-window}).

65
doc/emacs/msdos.texi
View file

@ -1025,7 +1025,7 @@ symbols, as in @code{(uniscribe)} or @w{@code{(harfbuzz uniscribe gdi)}}.
@cindex font properties (MS Windows)
@noindent
Optional properties common to all font backends on MS-Windows are:
Optional font properties supported on MS-Windows are:
@table @code
@ -1078,40 +1078,61 @@ Not used on Windows, but for informational purposes and to
prevent problems with code that expects it to be set, is set internally to
@code{raster} for bitmapped fonts, @code{outline} for scalable fonts,
or @code{unknown} if the type cannot be determined as one of those.
@end table
@cindex font properties (MS Windows gdi backend)
Options specific to @code{GDI} fonts:
@table @code
@cindex font scripts (MS Windows)
@cindex font Unicode subranges (MS Windows)
@item script
Specifies a Unicode subrange the font should support.
The following scripts are recognized on Windows: @code{latin}, @code{greek},
@code{coptic}, @code{cyrillic}, @code{armenian}, @code{hebrew}, @code{arabic},
@code{syriac}, @code{nko}, @code{thaana}, @code{devanagari}, @code{bengali},
@code{gurmukhi}, @code{gujarati}, @code{oriya}, @code{tamil}, @code{telugu},
@code{kannada}, @code{malayam}, @code{sinhala}, @code{thai}, @code{lao},
@code{tibetan}, @code{myanmar}, @code{georgian}, @code{hangul},
@code{ethiopic}, @code{cherokee}, @code{canadian-aboriginal}, @code{ogham},
@code{runic}, @code{khmer}, @code{mongolian}, @code{symbol}, @code{braille},
@code{han}, @code{ideographic-description}, @code{cjk-misc}, @code{kana},
@code{bopomofo}, @code{kanbun}, @code{yi}, @code{byzantine-musical-symbol},
@code{musical-symbol}, and @code{mathematical}.
All the scripts known to Emacs (which generally means all the scripts
defined by the latest Unicode Standard) are recognized on MS-Windows.
However, @code{GDI} fonts support only a subset of the known scripts:
@code{greek}, @code{hangul}, @code{kana}, @code{kanbun},
@code{bopomofo}, @code{tibetan}, @code{yi}, @code{mongolian},
@code{hebrew}, @code{arabic}, and @code{thai}.
@cindex font antialiasing (MS Windows)
@cindex Cleartype
@item antialias
Specifies the antialiasing method. The value @code{none} means no
antialiasing, @code{standard} means use standard antialiasing,
@code{subpixel} means use subpixel antialiasing (known as Cleartype on
Windows), and @code{natural} means use subpixel antialiasing with
adjusted spacing between letters. If unspecified, the font will use
the system default antialiasing.
@code{subpixel} means use subpixel antialiasing (known as
@dfn{Cleartype} on Windows), and @code{natural} means use subpixel
antialiasing with adjusted spacing between letters. If unspecified,
the font will use the system default antialiasing.
@end table
@cindex font lookup, MS-Windows
@findex w32-find-non-USB-fonts
The method used by Emacs on MS-Windows to look for fonts suitable for
displaying a given non-@sc{ascii} character might fail for some rare
scripts, specifically those added by Unicode relatively recently, even
if you have fonts installed on your system that support those scripts.
That is because these scripts have no Unicode Subrange Bits (USBs)
defined for them in the information used by Emacs on MS-Windows to
look for fonts. You can use the @code{w32-find-non-USB-fonts}
function to overcome these problems. It needs to be run once at the
beginning of the Emacs session, and again if you install new fonts.
You can add the following line to your init file to have this function
run every time you start Emacs:
@lisp
(w32-find-non-USB-fonts)
@end lisp
@noindent
@vindex w32-non-USB-fonts
Alternatively, you can run this function manually via @kbd{M-:}
(@pxref{Lisp Eval}) at any time. On a system that has many fonts
installed, running @code{w32-find-non-USB-fonts} might take a couple
of seconds; if you consider that to be too long to be run during
startup, and if you install new fonts only rarely, run this function
once via @kbd{M-:}, and then assign the value it returns, if
non-@code{nil}, to the variable @code{w32-non-USB-fonts} in your init
file. (If the function returns @code{nil}, you have no fonts
installed that can display characters from the scripts which need this
facility.)
@node Windows Misc
@section Miscellaneous Windows-specific features

4
doc/emacs/mule.texi
View file

@ -497,6 +497,10 @@ one of them selects that alternative. The keys @kbd{C-f}, @kbd{C-b},
do the highlighting in the buffer showing the possible characters,
rather than in the echo area.
To enter characters according to the @dfn{pīnyīn} transliteration
method instead, use the @code{chinese-sisheng} input method. This is
a composition based method, where e.g. @kbd{pi1} results in @samp{pī}.
In Japanese input methods, first you input a whole word using
phonetic spelling; then, after the word is in the buffer, Emacs
converts it into one or more characters using a large dictionary. One

10
doc/emacs/search.texi
View file

@ -262,11 +262,19 @@ of whether to copy a character or a symbol is heuristic.)
@kindex M-s C-e @r{(Incremental search)}
@findex isearch-yank-line
Similarly, @kbd{M-s C-e} (@code{isearch-yank-line}) appends the rest
@kbd{M-s C-e} (@code{isearch-yank-line}) appends the rest
of the current line to the search string. If point is already at the
end of a line, it appends the next line. With a prefix argument
@var{n}, it appends the next @var{n} lines.
@kindex C-M-z @r{(Incremental search)}
@findex isearch-yank-until-char
Similarly, @kbd{C-M-z} (@code{isearch-yank-until-char}) appends to
the search string everything from point until the next occurence of
a specified character (not including that character). This is especially
useful for keyboard macros, for example in programming languages or
markup languages in which that character marks a token boundary.
@kindex C-y @r{(Incremental search)}
@kindex M-y @r{(Incremental search)}
@kindex mouse-2 @r{in the minibuffer (Incremental search)}

3
doc/lispref/debugging.texi
View file

@ -457,6 +457,9 @@ Collapse the top-level Lisp form at point back to a single line.
@item #
Toggle @code{print-circle} for the frame at point.
@item :
Toggle @code{print-gensym} for the frame at point.
@item .
Expand all the forms abbreviated with ``...'' in the frame at point.

6
doc/lispref/display.texi
View file

@ -25,7 +25,7 @@ that Emacs presents to the user.
* Fringes:: Controlling window fringes.
* Scroll Bars:: Controlling scroll bars.
* Window Dividers:: Separating windows visually.
* Display Property:: Enabling special display features.
* Display Property:: Images, margins, text size, etc.
* Images:: Displaying images in Emacs buffers.
* Xwidgets:: Displaying native widgets in Emacs buffers.
* Buttons:: Adding clickable buttons to Emacs buffers.
@ -5016,7 +5016,9 @@ means no right marginal area.
Setting these variables does not immediately affect the window. These
variables are checked when a new buffer is displayed in the window.
Thus, you can make changes take effect by calling
@code{set-window-buffer}.
@code{set-window-buffer}. Do not use these variables to try to
determine the current width of the left or right margin. Instead, use
the function @code{window-margins}.
You can also set the margin widths immediately.

13
doc/lispref/files.texi
View file

@ -856,8 +856,7 @@ systems, this is true if the file exists and you have execute
permission on the containing directories, regardless of the
permissions of the file itself.)
If the file does not exist, or if access control policies prevent you
from finding its attributes, this function returns @code{nil}.
If the file does not exist, this function returns @code{nil}.
Directories are files, so @code{file-exists-p} can return @code{t} when
given a directory. However, because @code{file-exists-p} follows
@ -1262,7 +1261,7 @@ on the 19th, @file{aug-20} was written on the 20th, and the file
@defun file-attributes filename &optional id-format
@anchor{Definition of file-attributes}
This function returns a list of attributes of file @var{filename}. If
the specified file's attributes cannot be accessed, it returns @code{nil}.
the specified file does not exist, it returns @code{nil}.
This function does not follow symbolic links.
The optional parameter @var{id-format} specifies the preferred format
of attributes @acronym{UID} and @acronym{GID} (see below)---the
@ -1464,9 +1463,8 @@ The underlying ACL implementation is platform-specific; on GNU/Linux
and BSD, Emacs uses the POSIX ACL interface, while on MS-Windows Emacs
emulates the POSIX ACL interface with native file security APIs.
If Emacs was not compiled with ACL support, or the file does not exist
or is inaccessible, or Emacs was unable to determine the ACL entries
for any other reason, then the return value is @code{nil}.
If ACLs are not supported or the file does not exist,
then the return value is @code{nil}.
@end defun
@defun file-selinux-context filename
@ -1478,8 +1476,7 @@ for details about what these actually mean. The return value has the
same form as what @code{set-file-selinux-context} takes for its
@var{context} argument (@pxref{Changing Files}).
If Emacs was not compiled with SELinux support, or the file does not
exist or is inaccessible, or if the system does not support SELinux,
If SELinux is not supported or the file does not exist,
then the return value is @code{(nil nil nil nil)}.
@end defun

13
doc/lispref/internals.texi
View file

@ -533,9 +533,6 @@ be allocated for Lisp objects after one garbage collection in order to
trigger another garbage collection. You can use the result returned by
@code{garbage-collect} to get an information about size of the particular
object type; space allocated to the contents of buffers does not count.
Note that the subsequent garbage collection does not happen immediately
when the threshold is exhausted, but only the next time the Lisp interpreter
is called.
The initial threshold value is @code{GC_DEFAULT_THRESHOLD}, defined in
@file{alloc.c}. Since it's defined in @code{word_size} units, the value
@ -562,6 +559,16 @@ increases. Thus, it can be desirable to do them less frequently in
proportion.
@end defopt
Control over the garbage collector via @code{gc-cons-threshold} and
@code{gc-cons-percentage} is only approximate. Although Emacs checks
for threshold exhaustion regularly, for efficiency reasons it does not
do so immediately after every change to the heap or to
@code{gc-cons-threshold} or @code{gc-cons-percentage}, so exhausting
the threshold does not immediately trigger garbage collection. Also,
for efficency in threshold calculations Emacs approximates the heap
size, which counts the bytes used by currently-accessible objects in
the heap.
The value returned by @code{garbage-collect} describes the amount of
memory used by Lisp data, broken down by data type. By contrast, the
function @code{memory-limit} provides information on the total amount of

2
doc/lispref/searching.texi
View file

@ -1183,7 +1183,7 @@ Match @var{rx}, with @code{zero-or-more}, @code{0+},
@cindex @code{maximal-match} in rx
Match @var{rx}, with @code{zero-or-more}, @code{0+},
@code{one-or-more}, @code{1+}, @code{zero-or-one}, @code{opt} and
@code{optional} using non-greedy matching. This is the default.
@code{optional} using greedy matching. This is the default.
@end table
@subsubheading Matching single characters

2
doc/misc/efaq.texi
View file

@ -21,7 +21,7 @@ Copyright @copyright{} 1990, 1991, 1992 Joseph Brian Wells@*
@quotation
This list of frequently asked questions about GNU Emacs with answers
(``FAQ'') may be translated into other languages, transformed into other
formats (e.g., Texinfo, Info, WWW, WAIS), and updated with new information.
formats (e.g., Texinfo, Info, HTML, PDF), and updated with new information.
The same conditions apply to any derivative of the FAQ as apply to the FAQ
itself. Every copy of the FAQ must include this notice or an approved

17
doc/misc/emacs-mime.texi
View file

@ -375,16 +375,13 @@ message as follows:
@item mm-inline-large-images
@vindex mm-inline-large-images
When displaying inline images that are larger than the window, Emacs
does not enable scrolling, which means that you cannot see the whole
image. To prevent this, the library tries to determine the image size
before displaying it inline, and if it doesn't fit the window, the
library will display it externally (e.g., with @samp{ImageMagick} or
@samp{xv}). Setting this variable to @code{t} disables this check and
makes the library display all inline images as inline, regardless of
their size. If you set this variable to @code{resize}, the image will
be displayed resized to fit in the window, if Emacs has the ability to
resize images.
This variable is @code{resize} by default, which means that images
that are bigger than the Emacs window are resized so that they fit.
If you set this to @code{nil}, large images are not displayed in
Emacs, but can instead be displayed externally (e.g., with
@samp{ImageMagick} or @samp{xv}). Setting this variable to @code{t}
disables this check and makes the library display all inline images as
inline, regardless of their size.
@item mm-inline-large-images-proportion
@vindex mm-inline-images-max-proportion

2
doc/misc/gnus.texi
View file

@ -23682,7 +23682,7 @@ point your Web browser at
@uref{http://www.cs.indiana.edu/picons/ftp/index.html}.
If you are using Debian GNU/Linux, saying @samp{apt-get install
picons.*} will install the picons where Gnus can find them.
picon-.*} will install the picons where Gnus can find them.
To enable displaying picons, simply make sure that
@code{gnus-picon-databases} points to the directory containing the

7
doc/misc/smtpmail.texi
View file

@ -372,6 +372,13 @@ implement support for common requirements.
@table @code
@item smtpmail-retries
@vindex smtpmail-retries
An SMTP server may return an error code saying that there's a
transient error (a @samp{4xx} code). In that case, smtpmail will try
to resend the message automatically, and the number of times it tries
before giving up is determined by this variable, which defaults to 10.
@item smtpmail-local-domain
@vindex smtpmail-local-domain
The variable @code{smtpmail-local-domain} controls the hostname sent

29
doc/misc/tramp.texi
View file

@ -1591,6 +1591,7 @@ via the @command{CONNECT} command (conforming to RFC 2616, 2817
specifications). Proxy servers using HTTP 1.1 or later protocol
support this command.
@subsection Tunneling with ssh
With ssh, you could use the @code{ProxyCommand} entry in
@ -1609,6 +1610,7 @@ Any other program with such a feature could be used as well.
In the example, opening @file{@trampfn{ssh,host.your.domain,}} passes
the HTTP proxy server @samp{proxy.your.domain} on port 3128.
@subsection Tunneling with PuTTY
PuTTY does not need an external program, HTTP tunnel support is
@ -2092,6 +2094,33 @@ be recomputed. To force @value{tramp} to recompute afresh, call
@node Remote shell setup
@section Remote shell setup hints
@subsection Changing the default remote shell
@cindex zsh setup
Per default, @value{tramp} uses the command @command{/bin/sh} for
strting a shell on the remote host. This can be changed by setting
the connection property @option{remote-shell}, see @xref{Predefined
connection information}. Other properties might be adapted as well,
like @option{remote-shell-login} or @option{remote-shell-args}. If
you want, for example, use @command{/usr/bin/zsh} on a remote host,
you might apply
@lisp
@group
(add-to-list 'tramp-connection-properties
(list (regexp-quote "@trampfn{ssh,user@@host,}")
"remote-shell" "/usr/bin/zsh"))
@end group
@end lisp
This approach has also the advantage, that settings in
@code{tramp-sh-extra-args} will be applied. For zsh, the trouble
with the shell prompt due to set zle options will be avoided.
@subsection Other remote shell setup hints
@cindex remote shell setup
@cindex @file{.profile} file
@cindex @file{.login} file

4
etc/HELLO
View file

@ -79,7 +79,9 @@ Spanish (espa</x-charset><x-charset><param>latin-iso8859-1</param>ñol) ¡Hola!
Swedish (svenska) Hej / Goddag / Hallå
</x-charset><x-charset><param>mule-unicode-0100-24ff</param>Tamil (தமிழ்) வணக்கம்
Telugu (తెలుగు) నమస్కారం
</x-charset><x-charset><param>thai-tis620</param>Thai (ภาษาไทย) สวัสดีครับ / สวัสดีค่ะ
</x-charset>TaiViet (ꪁꪫꪱꪣ ꪼꪕ) ꪅꪰꪙꫂ ꪨꪮꫂ ꪁꪫꪱ / ꪅꪽ ꪨꪷ ꪁꪫꪱ
<x-charset><param>thai-tis620</param>Thai (ภาษาไทย) สวัสดีครับ / สวัสดีค่ะ
</x-charset><x-charset><param>tibetan</param>Tibetan (བོད་སྐད་) བཀྲ་ཤིས་བདེ་ལེགས༎
</x-charset><x-charset><param>mule-unicode-0100-24ff</param>Tigrigna (ትግርኛ) ሰላማት
</x-charset><x-charset><param>latin-iso8859-9</param>Turkish (Türkçe) Merhaba

63
etc/NEWS
View file

@ -196,10 +196,6 @@ the new version of the file again.)
** emacsclient
*** emacsclient no longer passes '--eval' arguments to an alternate editor.
Previously, '--eval' arguments were passed as file names to any
alternate editor started by '--alternate-editor'.
+++
*** emacsclient now supports an 'EMACS_SOCKET_NAME' environment variable.
The command-line argument '--socket-name' overrides it.
@ -743,6 +739,10 @@ file.
*** New customizable variable 'vc-find-revision-no-save'.
With non-nil, 'vc-find-revision' doesn't write the created buffer to file.
---
*** 'vc-dir-ignore' now takes a prefix argument to ignore all marked
files.
*** New customizable variable 'vc-git-grep-template'.
This new variable allows customizing the default arguments passed to
'git-grep' when 'vc-git-grep' is used.
@ -1018,6 +1018,9 @@ only one hit. This can be altered by changing
*** Xref buffers support refreshing the search results.
A new command 'xref-revert-buffer' is bound to 'g'.
---
*** Imenu support has been added to 'xref--xref-buffer-mode'.
** Ecomplete
*** The ecomplete sorting has changed to a decay-based algorithm.
@ -1062,6 +1065,11 @@ See the concept index in the Gnus manual for the 'match-list' entry.
+++
*** nil is no longer an allowed value for 'mm-text-html-renderer'.
+++
The default value of 'mm-inline-large-images' has changed from nil to
'resize', which means that large images will be resized instead of
displayed with an external program by default.
+++
*** A new Gnus summary mode command, 'S A'
('gnus-summary-attach-article') can be used to attach the current
@ -1157,6 +1165,11 @@ defining new 'cl-defmethod' of 'smtpmail-try-auth-method'.
attempt when communicating with the SMTP server(s), the
'smtpmail-servers-requiring-authorization' variable can be used.
+++
*** smtpmail will now try resending mail when getting a transient 4xx
error message from the SMTP server. The new 'smtpmail-retries'
variable says how many times to retry.
** Footnote mode
*** Support Hebrew-style footnotes
@ -1255,6 +1268,11 @@ highlight in one iteration while processing the full buffer.
+++
*** New isearch bindings.
'C-M-z' invokes new function 'isearch-yank-until-char', which yanks
everything from point up to but not including the specified
character into the search string. This is especially useful for
keyboard macros.
'C-M-w' in isearch changed from 'isearch-del-char' to the new function
'isearch-yank-symbol-or-char'. 'isearch-del-char' is now bound to
'C-M-d'.
@ -1370,6 +1388,10 @@ the Elisp manual for documentation of the new mode and its commands.
dimensions, instead of always using 16 pixels. As a result, Tetris,
Snake and Pong are more playable on HiDPI displays.
---
*** 'gamegrid-add-score' can now sort scores from lower to higher.
This is useful for games where lower scores are better, like time-based games.
** Filecache
---
@ -1895,14 +1917,9 @@ and 'gravatar-force-default'.
** ada-mode
*** The built-in ada-mode is now deleted. The Gnu ELPA package is a
*** The built-in ada-mode is now deleted. The GNU ELPA package is a
good replacement, even in very large source files.
** xref
---
*** Imenu support has been added to 'xref--xref-buffer-mode'.
* New Modes and Packages in Emacs 27.1
@ -1938,6 +1955,7 @@ long lines will (subject to configuration) cause the user's preferred
major mode is replaced by 'so-long-mode'). In extreme cases this can
prevent delays of several minutes, and make Emacs responsive almost
immediately. Type 'M-x so-long-commentary' for full documentation.
* Incompatible Lisp Changes in Emacs 27.1
@ -1992,6 +2010,16 @@ file name if there is no user named "foo".
** The FILENAME argument to 'file-name-base' is now mandatory and no
longer defaults to 'buffer-file-name'.
+++
** File metadata primitives now signal an error if I/O, access, or
other serious errors prevent them from determining the result.
Formerly, these functions often (though not always) returned nil.
For example, if searching /etc/firewalld results in an I/O error,
(file-symlink-p "/etc/firewalld/firewalld.conf") now signals an error
instead of returning nil, because file-symlink-p cannot determine
whether a symbolic link exists there. These functions still behave as
before if the only problem is that the file does not exist.
---
** The function 'eldoc-message' now accepts a single argument.
Programs that called it with multiple arguments before should pass
@ -2425,6 +2453,13 @@ remote systems, which support this check.
+++
** 'memory-limit' now returns a better estimate of memory consumption.
+++
** When interpreting 'gc-cons-percentage', Emacs now estimates the
heap size more often and (we hope) more accurately. E.g., formerly
(progn (let ((gc-cons-percentage 0.8)) BODY1) BODY2) continued to use
the 0.8 value during BODY2 until the next garbage collection, but that
is no longer true. Applications may need to re-tune their GC tricks.
+++
** New macro 'combine-change-calls' arranges to call the change hooks
('before-change-functions' and 'after-change-functions') just once
@ -2683,6 +2718,14 @@ corresponding encoding, instead of using 'w32-ansi-code-page'.
Experience shows that compacting font caches causes more trouble on
MS-Windows than it helps.
+++
** Font lookup on MS-Windows was improved to support rare scripts.
To activate the improvement, run the new function
'w32-find-non-USB-fonts' once per Emacs session, or assign to the new
variable 'w32-non-USB-fonts' the list of scripts and the corresponding
fonts. See the documentation of this function and variable in the
Emacs manual for more details.
+++
** On NS the behaviour of drag and drop can now be modified by use of
modifier keys in line with Apples guidelines. This makes the drag and

6
lib-src/emacsclient.c
View file

@ -700,11 +700,7 @@ fail (void)
{
if (alternate_editor)
{
/* If the user has said --eval, then those aren't file name
parameters, so don't put them on the alternate_editor command
line. */
size_t extra_args_size =
(eval? 0: (main_argc - optind + 1) * sizeof (char *));
size_t extra_args_size = (main_argc - optind + 1) * sizeof (char *);
size_t new_argv_size = extra_args_size;
char **new_argv = xmalloc (new_argv_size);
char *s = xstrdup (alternate_editor);

2
lisp/calc/calc-prog.el
View file

@ -1097,7 +1097,7 @@ Redefine the corresponding command."
(or func (setq func (and cmd (symbolp cmd) (fboundp cmd) cmd)))
(if (get func 'math-compose-forms)
(let ((pt (point)))
(insert "(put '" (symbol-name cmd)
(insert "(put '" (symbol-name func)
" 'math-compose-forms '"
(prin1-to-string (get func 'math-compose-forms))
")\n")

7
lisp/cus-edit.el
View file

@ -2212,7 +2212,12 @@ and `face'."
(unless (eq state 'modified)
(unless (memq state '(nil unknown hidden))
(widget-put widget :custom-state 'modified))
(custom-magic-reset widget)
;; Update the status text (usually from "STANDARD" to "EDITED
;; bla bla" in the buffer after the command has run. Otherwise
;; commands like `M-u' (that work on a region in the buffer)
;; will upcase the wrong part of the buffer, since more text has
;; been inserted before point.
(run-with-idle-timer 0.0 nil #'custom-magic-reset widget)
(apply 'widget-default-notify widget args))))
(defun custom-redraw (widget)

3
lisp/emacs-lisp/autoload.el
View file

@ -398,9 +398,8 @@ FILE's name."
;; Probably pointless, but replaces the old AUTOGEN_VCS in lisp/Makefile,
;; which was designed to handle CVSREAD=1 and equivalent.
(and autoload-ensure-writable
(file-exists-p file)
(let ((modes (file-modes file)))
(if (zerop (logand modes #o0200))
(if (and modes (zerop (logand modes #o0200)))
;; Ignore any errors here, and let subsequent attempts
;; to write the file raise any real error.
(ignore-errors (set-file-modes file (logior modes #o0200))))))

44
lisp/emacs-lisp/backtrace.el
View file

@ -175,7 +175,8 @@ This should be a list of `backtrace-frame' objects.")
(defvar-local backtrace-view nil
"A plist describing how to render backtrace frames.
Possible entries are :show-flags, :show-locals and :print-circle.")
Possible entries are :show-flags, :show-locals, :print-circle
and :print-gensym.")
(defvar-local backtrace-insert-header-function nil
"Function for inserting a header for the current Backtrace buffer.
@ -205,6 +206,7 @@ frames where the source code location is known.")
(define-key map "p" 'backtrace-backward-frame)
(define-key map "v" 'backtrace-toggle-locals)
(define-key map "#" 'backtrace-toggle-print-circle)
(define-key map ":" 'backtrace-toggle-print-gensym)
(define-key map "s" 'backtrace-goto-source)
(define-key map "\C-m" 'backtrace-help-follow-symbol)
(define-key map "+" 'backtrace-multi-line)
@ -224,6 +226,18 @@ frames where the source code location is known.")
:active (backtrace-get-index)
:selected (plist-get (backtrace-get-view) :show-locals)
:help "Show or hide the local variables for the frame at point"]
["Show Circular Structures" backtrace-toggle-print-circle
:style toggle
:active (backtrace-get-index)
:selected (plist-get (backtrace-get-view) :print-circle)
:help
"Condense or expand shared or circular structures in the frame at point"]
["Show Uninterned Symbols" backtrace-toggle-print-gensym
:style toggle
:active (backtrace-get-index)
:selected (plist-get (backtrace-get-view) :print-gensym)
:help
"Toggle unique printing of uninterned symbols in the frame at point"]
["Expand \"...\"s" backtrace-expand-ellipses
:help "Expand all the abbreviated forms in the current frame"]
["Show on Multiple Lines" backtrace-multi-line
@ -339,6 +353,7 @@ It runs `backtrace-revert-hook', then calls `backtrace-print'."
`(let ((print-escape-control-characters t)
(print-escape-newlines t)
(print-circle (plist-get ,view :print-circle))
(print-gensym (plist-get ,view :print-gensym))
(standard-output (current-buffer)))
,@body))
@ -420,12 +435,18 @@ Set it to VALUE unless the button is a `backtrace-ellipsis' button."
(defun backtrace-toggle-print-circle (&optional all)
"Toggle `print-circle' for the backtrace frame at point.
With prefix argument ALL, toggle the value of :print-circle in
`backtrace-view', which affects all of the backtrace frames in
the buffer."
With prefix argument ALL, toggle the default value bound to
`print-circle' for all the frames in the buffer."
(interactive "P")
(backtrace--toggle-feature :print-circle all))
(defun backtrace-toggle-print-gensym (&optional all)
"Toggle `print-gensym' for the backtrace frame at point.
With prefix argument ALL, toggle the default value bound to
`print-gensym' for all the frames in the buffer."
(interactive "P")
(backtrace--toggle-feature :print-gensym all))
(defun backtrace--toggle-feature (feature all)
"Toggle FEATURE for the current backtrace frame or for the buffer.
FEATURE should be one of the options in `backtrace-view'. If ALL
@ -450,12 +471,15 @@ position point at the start of the frame it was in before."
(goto-char (point-min))
(while (and (not (eql index (backtrace-get-index)))
(< (point) (point-max)))
(goto-char (backtrace-get-frame-end)))))
(let ((index (backtrace-get-index)))
(unless index
(user-error "Not in a stack frame"))
(backtrace--set-feature feature
(not (plist-get (backtrace-get-view) feature))))))
(goto-char (backtrace-get-frame-end))))
(message "%s is now %s for all frames"
(substring (symbol-name feature) 1) value))
(unless (backtrace-get-index)
(user-error "Not in a stack frame"))
(let ((value (not (plist-get (backtrace-get-view) feature))))
(backtrace--set-feature feature value)
(message "%s is now %s for this frame"
(substring (symbol-name feature) 1) value))))
(defun backtrace--set-feature (feature value)
"Set FEATURE in the view plist of the frame at point to VALUE.

21
lisp/emacs-lisp/cl-print.el
View file

@ -548,21 +548,22 @@ limit."
;; call_debugger (bug#31919).
(let* ((print-length (when limit (min limit 50)))
(print-level (when limit (min 8 (truncate (log limit)))))
(delta (when limit
(max 1 (truncate (/ print-length print-level))))))
(delta-length (when limit
(max 1 (truncate (/ print-length print-level))))))
(with-temp-buffer
(catch 'done
(while t
(erase-buffer)
(funcall print-function value (current-buffer))
;; Stop when either print-level is too low or the value is
;; successfully printed in the space allowed.
(when (or (not limit)
(< (- (point-max) (point-min)) limit)
(= print-level 2))
(throw 'done (buffer-string)))
(cl-decf print-level)
(cl-decf print-length delta))))))
(let ((result (- (point-max) (point-min))))
;; Stop when either print-level is too low or the value is
;; successfully printed in the space allowed.
(when (or (not limit) (< result limit) (<= print-level 2))
(throw 'done (buffer-string)))
(let* ((ratio (/ result limit))
(delta-level (max 1 (min (- print-level 2) ratio))))
(cl-decf print-level delta-level)
(cl-decf print-length (* delta-length delta-level)))))))))
(provide 'cl-print)
;;; cl-print.el ends here

2
lisp/emacs-lisp/elint.el
View file

@ -106,7 +106,7 @@ are as follows, and suppress messages about the indicated features:
:group 'elint)
(defcustom elint-directory-skip-re "\\(ldefs-boot\\|loaddefs\\)\\.el\\'"
"If nil, a regexp matching files to skip when linting a directory."
"If non-nil, a regexp matching files to skip when linting a directory."
:type '(choice (const :tag "Lint all files" nil)
(regexp :tag "Regexp to skip"))
:safe 'string-or-null-p

6
lisp/emulation/viper.el
View file

@ -1,4 +1,4 @@
;;; viper.el --- A full-featured Vi emulator for Emacs and XEmacs, -*-lexical-binding:t -*-
;;; viper.el --- A full-featured Vi emulator for Emacs -*- lexical-binding:t -*-
;; a VI Plan for Emacs Rescue,
;; and a venomous VI PERil.
;; Viper Is also a Package for Emacs Rebels.
@ -34,7 +34,7 @@
;;; Commentary:
;; Viper is a full-featured Vi emulator for Emacs and XEmacs. It emulates and
;; Viper is a full-featured Vi emulator for Emacs. It emulates and
;; improves upon the standard features of Vi and, at the same time, allows
;; full access to all Emacs facilities. Viper supports multiple undo,
;; file name completion, command, file, and search history and it extends
@ -541,7 +541,7 @@ If Viper is enabled, turn it off. Otherwise, turn it on."
"Viper Is a Package for Emacs Rebels,
a VI Plan for Emacs Rescue, and a venomous VI PERil.
Incidentally, Viper emulates Vi under Emacs/XEmacs 20.
Incidentally, Viper emulates Vi under Emacs.
It supports all of what is good in Vi and Ex, while extending
and improving upon much of it.

10
lisp/files.el
View file

@ -2554,13 +2554,13 @@ unless NOMODES is non-nil."
(auto-save-mode 1)))
;; Make people do a little extra work (C-x C-q)
;; before altering a backup file.
(when (backup-file-name-p buffer-file-name)
(setq buffer-read-only t))
;; When a file is marked read-only,
;; make the buffer read-only even if root is looking at it.
(when (and (file-modes (buffer-file-name))
(zerop (logand (file-modes (buffer-file-name)) #o222)))
(setq buffer-read-only t))
(unless buffer-read-only
(when (or (backup-file-name-p buffer-file-name)
(let ((modes (file-modes (buffer-file-name))))
(and modes (zerop (logand modes #o222)))))
(setq buffer-read-only t)))
(unless nomodes
(when (and view-read-only view-mode)
(view-mode -1))

12
lisp/gnus/gnus-art.el
View file

@ -5378,9 +5378,9 @@ Compressed files like .gz and .bz2 are decompressed."
'gnus-undeletable t))))
;; We're in the article header.
(delete-char -1)
(dolist (ovl (overlays-in btn (point)))
(let ((ovl (make-overlay btn (point))))
(overlay-put ovl 'gnus-button-attachment-extra t)
(overlay-put ovl 'face nil))
(overlay-put ovl 'evaporate t))
(save-restriction
(message-narrow-to-field)
(let ((gnus-treatment-function-alist
@ -5763,9 +5763,9 @@ all parts."
'gnus-undeletable t))))
;; We're in the article header.
(delete-char -1)
(dolist (ovl (overlays-in point (point)))
(let ((ovl (make-overlay point (point))))
(overlay-put ovl 'gnus-button-attachment-extra t)
(overlay-put ovl 'face nil))
(overlay-put ovl 'evaporate t))
(save-restriction
(message-narrow-to-field)
(let ((gnus-treatment-function-alist
@ -6379,9 +6379,9 @@ in the body. Use `gnus-header-face-alist' to highlight buttons."
(insert "\n")
(end-of-line)))
(insert "\n")
(dolist (ovl (overlays-in (point-min) (point)))
(let ((ovl (make-overlay (point-min) (point))))
(overlay-put ovl 'gnus-button-attachment-extra t)
(overlay-put ovl 'face nil))
(overlay-put ovl 'evaporate t))
(let ((gnus-treatment-function-alist
'((gnus-treat-highlight-headers
gnus-article-highlight-headers))))

5
lisp/gnus/gnus-start.el
View file

@ -897,9 +897,8 @@ If REGEXP is given, lines that match it will be deleted."
(set-buffer-modified-p t))
;; Set the file modes to reflect the .newsrc file modes.
(save-buffer)
(when (and (file-exists-p gnus-current-startup-file)
(file-exists-p dribble-file)
(setq modes (file-modes gnus-current-startup-file)))
(when (and (setq modes (file-modes gnus-current-startup-file))
(file-exists-p dribble-file))
(gnus-set-file-modes dribble-file modes))
(goto-char (point-min))
(when (search-forward "Gnus was exited on purpose" nil t)

8
lisp/gnus/mm-decode.el
View file

@ -381,9 +381,11 @@ enables you to choose manually one of two types those mails include."
:type 'directory
:group 'mime-display)
(defcustom mm-inline-large-images nil
"If t, then all images fit in the buffer.
If `resize', try to resize the images so they fit."
(defcustom mm-inline-large-images 'resize
"If nil, images larger than the window aren't displayed in the buffer.
If `resize', try to resize the images so they fit in the buffer.
If t, show the images as they are without resizing."
:version "27.1"
:type '(radio
(const :tag "Inline large images as they are." t)
(const :tag "Resize large images." resize)

5
lisp/gnus/mm-view.el
View file

@ -65,8 +65,9 @@
:group 'mime-display)
(defcustom mm-inline-large-images-proportion 0.9
"Maximum proportion of large image resized when
`mm-inline-large-images' is set to resize."
"Maximum proportion large images can occupy in the buffer.
This is only used if `mm-inline-large-images' is set to
`resize'."
:type 'float
:version "24.1"
:group 'mime-display)

2
lisp/help-mode.el
View file

@ -59,7 +59,7 @@
["Next Topic" help-go-forward
:help "Go back to next topic in this help buffer"]
["Move to Previous Button" backward-button
:help "Move to the Next Button in the help buffer"]
:help "Move to the Previous Button in the help buffer"]
["Move to Next Button" forward-button
:help "Move to the Next Button in the help buffer"]))

6
lisp/htmlfontify.el
View file

@ -1938,9 +1938,9 @@ adding an extension of `hfy-extn'. Fontification is actually done by
(set-buffer html)
(write-file (concat target hfy-extn))
(kill-buffer html))
;; #o0200 == 128, but emacs20 doesn't know that
(if (and (file-exists-p target) (not (file-writable-p target)))
(set-file-modes target (logior (file-modes target) 128)))
(let ((modes (file-modes target)))
(if (and modes (not (file-writable-p target)))
(set-file-modes target (logior modes #o0200))))
(copy-file (buffer-file-name source) target 'overwrite))
(kill-buffer source)) ))

5
lisp/imenu.el
View file

@ -510,8 +510,9 @@ See `imenu--index-alist' for the format of the index alist."
"No items suitable for an index found in this buffer"))
(or imenu--index-alist
(setq imenu--index-alist (list nil)))
;; Add a rescan option to the index.
(cons imenu--rescan-item imenu--index-alist))
(unless imenu-auto-rescan
;; Add a rescan option to the index.
(cons imenu--rescan-item imenu--index-alist)))
(defvar imenu--cleanup-seen nil)

9
lisp/international/fontset.el
View file

@ -719,6 +719,7 @@
symbol
braille
yi
tai-viet
aegean-number
ancient-greek-number
ancient-symbol
@ -731,18 +732,26 @@
deseret
shavian
osmanya
osage
cypriot-syllabary
phoenician
lydian
kharoshthi
manichaean
elymaic
makasar
cuneiform-numbers-and-punctuation
cuneiform
egyptian
bassa-vah
pahawh-hmong
medefaidrin
byzantine-musical-symbol
musical-symbol
ancient-greek-musical-notation
tai-xuan-jing-symbol
counting-rod-numeral
adlam
mahjong-tile
domino-tile))
(set-fontset-font "fontset-default"

2
lisp/international/iso-transl.el
View file

@ -177,6 +177,8 @@
("c" . [?¢])
("*o" . [?°])
("o" . [?°])
("Oe" . [?œ])
("OE" . [?Œ])
("*u" . [?µ])
("u" . [?µ])
("*m" . [?µ])

29
lisp/isearch.el
View file

@ -514,6 +514,9 @@ This is like `describe-bindings', but displays only Isearch keys."
(define-key map [isearch-yank-kill]
'(menu-item "Current kill" isearch-yank-kill
:help "Append current kill to search string"))
(define-key map [isearch-yank-until-char]
'(menu-item "Until char..." isearch-yank-until-char
:help "Yank from point to specified character into search string"))
(define-key map [isearch-yank-line]
'(menu-item "Rest of line" isearch-yank-line
:help "Yank the rest of the current line on search string"))
@ -705,6 +708,7 @@ This is like `describe-bindings', but displays only Isearch keys."
(define-key map "\M-\C-d" 'isearch-del-char)
(define-key map "\M-\C-y" 'isearch-yank-char)
(define-key map "\C-y" 'isearch-yank-kill)
(define-key map "\M-\C-z" 'isearch-yank-until-char)
(define-key map "\M-s\C-e" 'isearch-yank-line)
(define-key map "\M-s\M-<" 'isearch-beginning-of-buffer)
@ -998,6 +1002,8 @@ Type \\[isearch-yank-word-or-char] to yank next word or character in buffer
Type \\[isearch-del-char] to delete character from end of search string.
Type \\[isearch-yank-char] to yank char from buffer onto end of search\
string and search for it.
Type \\[isearch-yank-until-char] to yank from point until the next instance of a
specified character onto end of search string and search for it.
Type \\[isearch-yank-line] to yank rest of line onto end of search string\
and search for it.
Type \\[isearch-yank-kill] to yank the last string of killed text.
@ -1364,7 +1370,6 @@ NOPUSH is t and EDIT is t."
(remove-hook 'post-command-hook 'isearch-post-command-hook)
(remove-hook 'mouse-leave-buffer-hook 'isearch-mouse-leave-buffer)
(remove-hook 'kbd-macro-termination-hook 'isearch-done)
(setq isearch-lazy-highlight-start nil)
(when (buffer-live-p isearch--current-buffer)
(with-current-buffer isearch--current-buffer
(setq isearch--current-buffer nil)
@ -2562,6 +2567,23 @@ If optional ARG is non-nil, pull in the next ARG words."
(interactive "p")
(isearch-yank-internal (lambda () (forward-word arg) (point))))
(defun isearch-yank-until-char (char)
"Pull everything until next instance of CHAR from buffer into search string.
Interactively, prompt for CHAR.
This is often useful for keyboard macros, for example in programming
languages or markup languages in which CHAR marks a token boundary."
(interactive "cYank until character: ")
(isearch-yank-internal
(lambda () (let ((inhibit-field-text-motion t))
(condition-case nil
(progn
(search-forward (char-to-string char))
(forward-char -1))
(search-failed
(message "`%c' not found" char)
(sit-for 2)))
(point)))))
(defun isearch-yank-line (&optional arg)
"Pull rest of line from buffer into search string.
If optional ARG is non-nil, yank the next ARG lines."
@ -3947,8 +3969,9 @@ Attempt to do the search exactly the way the pending Isearch would."
(if isearch-lazy-highlight-forward
(setq isearch-lazy-highlight-end (point-min))
(setq isearch-lazy-highlight-start (point-max)))
(run-at-time lazy-highlight-interval nil
'isearch-lazy-highlight-buffer-update))
(setq isearch-lazy-highlight-timer
(run-at-time lazy-highlight-interval nil
'isearch-lazy-highlight-buffer-update)))
(setq isearch-lazy-highlight-timer
(run-at-time lazy-highlight-interval nil
'isearch-lazy-highlight-update)))))))))

23
lisp/language/tai-viet.el
View file

@ -39,21 +39,20 @@
(input-method . "tai-sonla")
(sample-text . "TaiViet (ꪁꪫꪱꪣ ꪼꪕ)\t\tꪅꪰꪙꫂ ꪨꪮꫂ ꪁꪫꪱ / ꪅꪽ ꪨꪷ ꪁꪫꪱ")
(documentation . "\
TaiViet refers to the Tai language used by Tai people in
Vietnam, and also refers to the script used for this language.
Both the script and language have the same origin as that of Thai
TaiViet refers to the Tai script, which is used to write several
Tai languages of northwestern Vietnam and surrounding areas. These
languages are Tai Dam (also known as Black Tai or Tai Noir),
Tai Dón (also known as White Tai or Tai Blanc), Tày Tac,
Tai Daeng (also known as Red Tai or Tai Rouge),
and Thai Song (also known as Lao Song). However, some people
consider Tai Dam, Tai Dón and Tai Daeng to be dialects of the
same language, and call them collectively \"Tai Viet\".
Both the script and languages have the same origin as that of Thai
language/script used in Thailand, but now they differ from each
other in a significant way (especially the scripts are).
The language name is spelled as \"ꪁꪫꪱꪣ ꪼꪕ\", and the script name is
spelled as \"ꪎ ꪼꪕ\" in the modern form, \"ꪎꪳ ꪼꪕ\" in the traditional
form.
As the proposal for TaiViet script to the Unicode is still on
the progress, we use the Private Use Area for TaiViet
characters (U+F000..U+F07E). A TaiViet font encoded accordingly
is available at this web page:
http://www.m17n.org/viettai/
")))
spelled as \"ꪎꪳ ꪼꪕ\".")))
(provide 'tai-viet)

37
lisp/leim/quail/ipa-praat.el
View file

@ -148,7 +148,14 @@ input | example | description
\\'1 | ˈ | primary stress
\\'2 | ˌ | secondary stress
\\cn | t̚ | unreleased plosive
\\rh | ɜ˞ | rhotacized vowel
\\hr | ɜ˞ | rhotacized vowel
\\^h | ʰ | aspiration
\\^H | ʱ | voiced aspiration
\\^w | ʷ | labialized, rounded
\\^j | ʲ | palatalized
\\^g | ˠ | velarized
\\^9 | ˤ | pharyngealized
- Understrikes
@ -168,7 +175,7 @@ input | example | description
\\Uv | d̺ | apical
\\Dv | d̻ | laminal
\\nv | u̯ | nonsyllabic
\\e3v | e̹ | slightly rounded
\\3v | e̹ | slightly rounded
\\cv | u̜ | slightly unrounded
- Overstrikes
@ -176,14 +183,14 @@ input | example | description
input | example | description
------+---------+--------------------------------------------
\\0^ | ɣ̊ | voiceless
\\'^ | | high tone
\\`^ | | low tone
\\-^ | | mid tone
\\~^ | | nasalized
\\v^ | | rising tone
\\^^ | | falling tone
\\:^ | | centralized
\\N^ | | short
\\'^ | é | high tone
\\`^ | è | low tone
\\-^ | ē | mid tone
\\~^ | ẽ | nasalized
\\v^ | ě | rising tone
\\^^ | ê | falling tone
\\:^ | ë | centralized
\\N^ | ĕ | short
\\li | k͡p | simultaneous articulation or single segment
"
nil t nil nil nil nil nil nil nil nil t)
@ -308,7 +315,13 @@ input | example | description
("\\'1" ?ˈ) ; primary stress
("\\'2" ?ˌ) ; secondary stress
("\\cn" #x031A) ; t̚ unreleased plosive
("\\rh" #x02DE) ; ɜ˞ rhotacized vowel
("\\hr" #x02DE) ; ɜ˞ rhotacized vowel
("\\^h" ?ʰ) ; ʰ aspiration (usually following a plosive)
("\\^H" ?ʱ) ; ʱ voiced aspiration (usually following a plosive)
("\\^w" ?ʷ) ; labialized
("\\^j" ?ʲ) ; palatalized
("\\^g" ?ˠ) ; velarized
("\\^9" ?ˤ) ; pharyngealized
("\\|v" #x0329) ; n̩ syllabic consonant
("\\0v" #x0325) ; b̥ voiceless
@ -324,7 +337,7 @@ input | example | description
("\\Uv" #x033A) ; d̺ apical
("\\Dv" #x033B) ; d̻ laminal
("\\nv" #x032F) ; u̯ nonsyllabic
("\\e3v" #x0339) ; e̹ slightly rounded
("\\3v" #x0339) ; e̹ slightly rounded
("\\cv" #x031C) ; u̜ slightly unrounded
("\\0^" #x030A) ; ɣ̊ voiceless

17
lisp/mail/feedmail.el
View file

@ -17,15 +17,6 @@
;; ability to queue messages for later sending. This replaces
;; the standalone fakemail program that used to be distributed with Emacs.
;; feedmail works with recent versions of Emacs (20.x series) and
;; XEmacs (tested with 20.4 and later betas). It probably no longer
;; works with Emacs v18, though I haven't tried that in a long
;; time. Makoto.Nakagawa@jp.compaq.com reports: "I have a report
;; that with a help of APEL library, feedmail works fine under emacs
;; 19.28. You can get APEL from ftp://ftp.m17n.org/pub/mule/apel/.
;; you need apel-10.2 or later to make feedmail work under emacs
;; 19.28."
;; Sorry, no manual yet in this release. Look for one with the next
;; release. Or the one after that. Or maybe later.
@ -437,9 +428,7 @@ shuttled robotically onward."
(defcustom feedmail-confirm-outgoing-timeout nil
"If non-nil, a timeout in seconds at the send confirmation prompt.
If a positive number, it's a timeout before sending. If a negative
number, it's a timeout before not sending. This will not work if your
version of Emacs doesn't include the function `y-or-n-p-with-timeout'
\(e.g., some versions of XEmacs)."
number, it's a timeout before not sending."
:version "24.1"
:group 'feedmail-misc
:type '(choice (const nil) integer)
@ -2004,9 +1993,7 @@ backup file names and the like)."
((feedmail-fqm-p blobby)
(setq blobby-buffer (generate-new-buffer (concat "FQM " blobby)))
(setq already-buffer
(if (fboundp 'find-buffer-visiting) ; missing from XEmacs
(find-buffer-visiting maybe-file)
(get-file-buffer maybe-file)))
(find-buffer-visiting maybe-file))
(if (and already-buffer (buffer-modified-p already-buffer))
(save-window-excursion
(display-buffer (set-buffer already-buffer))

28
lisp/mail/smtpmail.el
View file

@ -165,6 +165,13 @@ attempt."
:type '(choice regexp (const :tag "None" nil))
:version "27.1")
(defcustom smtpmail-retries 10
"The number of times smtpmail will retry sending when getting transient errors.
These are errors with a code of 4xx from the SMTP server, which
mean \"try again\"."
:type 'integer
:version "27.1")
;; End of customizable variables.
@ -654,10 +661,12 @@ Returns an error if the server cannot be contacted."
user-mail-address))))
(defun smtpmail-via-smtp (recipient smtpmail-text-buffer
&optional ask-for-password)
&optional ask-for-password
send-attempts)
(unless smtpmail-smtp-server
(smtpmail-query-smtp-server))
(let ((process nil)
(send-attempts (or send-attempts 1))
(host (or smtpmail-smtp-server
(error "`smtpmail-smtp-server' not defined")))
(port smtpmail-smtp-service)
@ -819,6 +828,23 @@ Returns an error if the server cannot be contacted."
((smtpmail-ok-p (setq result (smtpmail-read-response process)))
;; Success.
)
((and (numberp (car result))
(<= 400 (car result) 499)
(< send-attempts smtpmail-retries))
(message "Got transient error code %s when sending; retrying attempt %d..."
(car result) send-attempts)
;; Retry on getting a transient 4xx code; see
;; https://tools.ietf.org/html/rfc5321#section-4.2.1
(ignore-errors
(smtpmail-send-command process "QUIT")
(smtpmail-read-response process))
(delete-process process)
(sleep-for 1)
(setq process nil)
(throw 'done
(smtpmail-via-smtp recipient smtpmail-text-buffer
ask-for-password
(1+ send-attempts))))
((and auth-mechanisms
(not ask-for-password)
(eq (car result) 530))

14
lisp/mh-e/mh-acros.el
View file

@ -270,10 +270,16 @@ MH-E functions."
(declare (debug let) (indent 1))
;; Works in both lexical and non-lexical mode.
`(progn
,@(mapcar (lambda (binder)
`(defvar ,(if (consp binder) (car binder) binder)))
binders)
(let* ,binders ,@body)))
(with-suppressed-warnings ((lexical
,@(mapcar (lambda (binder)
(if (consp binder)
(car binder)
binder))
binders)))
,@(mapcar (lambda (binder)
`(defvar ,(if (consp binder) (car binder) binder)))
binders)
(let* ,binders ,@body))))
(provide 'mh-acros)

32
lisp/net/eww.el
View file

@ -326,6 +326,18 @@ the default EWW buffer."
#'url-hexify-string (split-string url) "+"))))))
url)
(defun eww--preprocess-html (start end)
"Translate all < characters that do not look like start of tags into &lt;."
(save-excursion
(save-restriction
(narrow-to-region start end)
(goto-char start)
(let ((case-fold-search t))
(while (re-search-forward "<[^0-9a-z!/]" nil t)
(goto-char (match-beginning 0))
(delete-region (point) (1+ (point)))
(insert "&lt;"))))))
;;;###autoload (defalias 'browse-web 'eww)
;;;###autoload
@ -479,6 +491,7 @@ Currently this means either text/html or application/xhtml+xml."
;; Remove CRLF and replace NUL with &#0; before parsing.
(while (re-search-forward "\\(\r$\\)\\|\0" nil t)
(replace-match (if (match-beginning 1) "" "&#0;") t t)))
(eww--preprocess-html (point) (point-max))
(libxml-parse-html-region (point) (point-max))))))
(source (and (null document)
(buffer-substring (point) (point-max)))))
@ -716,6 +729,7 @@ the like."
(condition-case nil
(decode-coding-region (point-min) (point-max) 'utf-8)
(coding-system-error nil))
(eww--preprocess-html (point-min) (point-max))
(libxml-parse-html-region (point-min) (point-max))))
(base (plist-get eww-data :url)))
(eww-score-readability dom)
@ -1433,15 +1447,15 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.")
(push (cons name (plist-get input :value))
values)))
((equal (plist-get input :type) "file")
(push (cons "file"
(list (cons "filedata"
(with-temp-buffer
(insert-file-contents
(plist-get input :filename))
(buffer-string)))
(cons "name" (plist-get input :name))
(cons "filename" (plist-get input :filename))))
values))
(when-let ((file (plist-get input :filename)))
(push (list "file"
(cons "filedata"
(with-temp-buffer
(insert-file-contents file)
(buffer-string)))
(cons "name" name)
(cons "filename" file))
values)))
((equal (plist-get input :type) "submit")
;; We want the values from buttons if we hit a button if
;; we hit enter on it, or if it's the first button after

9
lisp/net/net-utils.el
View file

@ -563,7 +563,7 @@ This command uses `nslookup-program' to look up DNS records."
(apply #'vector (mapcar #'string-to-number (split-string ip "\\."))))
(t (error "Invalid format: %s" format)))))
(defun ipv6-expand (ipv6-vector)
(defun nslookup--ipv6-expand (ipv6-vector)
(let ((len (length ipv6-vector)))
(if (< len 8)
(let* ((pivot (cl-position 0 ipv6-vector))
@ -598,9 +598,10 @@ This command uses `nslookup-program' to look up DNS records."
(cond ((memq format '(string nil))
ip)
((eq format 'vector)
(ipv6-expand (apply #'vector
(cl-loop for hextet in (split-string ip "[:]")
collect (string-to-number hextet 16)))))
(nslookup--ipv6-expand
(apply #'vector
(cl-loop for hextet in (split-string ip "[:]")
collect (string-to-number hextet 16)))))
(t (error "Invalid format: %s" format)))))
;;;###autoload

2
lisp/net/rfc2104.el
View file

@ -37,8 +37,6 @@
;; 64 is block length of hash function (64 for MD5 and SHA), 16 is
;; resulting hash length (16 for MD5, 20 for SHA).
;;
;; Tested with Emacs 20.2 and XEmacs 20.3.
;;
;; Test case reference: RFC 2202.
;;; History:

16
lisp/net/shr.el
View file

@ -1180,8 +1180,24 @@ Return a string with image data."
;; so glitches may occur during this transformation.
(shr-dom-to-xml
(libxml-parse-xml-region (point) (point-max)))))
;; SVG images often do not have a specified foreground/background
;; color, so wrap them in styles.
(when (eq content-type 'image/svg+xml)
(setq data (svg--wrap-svg data)))
(list data content-type)))
(defun svg--wrap-svg (data)
"Add a default foreground colour to SVG images."
(with-temp-buffer
(insert "<svg xmlns:xlink=\"http://www.w3.org/1999/xlink\" "
"xmlns:xi=\"http://www.w3.org/2001/XInclude\" "
"style=\"color: "
(face-foreground 'default) ";\">"
"<xi:include href=\"data:image/svg+xml;base64,"
(base64-encode-string data t)
"\"></xi:include></svg>")
(buffer-string)))
(defun shr-image-displayer (content-function)
"Return a function to display an image.
CONTENT-FUNCTION is a function to retrieve an image for a cid url that

12
lisp/net/tramp-adb.el
View file

@ -1191,6 +1191,10 @@ FMT and ARGS are passed to `error'."
"Maybe open a connection VEC.
Does not do anything if a connection is already open, but re-opens the
connection if a previous connection has died for some reason."
;; During completion, don't reopen a new connection.
(unless (tramp-connectable-p vec)
(throw 'non-essential 'non-essential))
(let* ((buf (tramp-get-connection-buffer vec))
(p (get-buffer-process buf))
(host (tramp-file-name-host vec))
@ -1204,14 +1208,6 @@ connection if a previous connection has died for some reason."
(tramp-error vec 'file-error "Cannot switch to user `%s'" user))
(unless (process-live-p p)
;; During completion, don't reopen a new connection. We check
;; this for the process related to `tramp-buffer-name';
;; otherwise `start-file-process' wouldn't run ever when
;; `non-essential' is non-nil.
(when (and (tramp-completion-mode-p)
(null (get-process (tramp-buffer-name vec))))
(throw 'non-essential 'non-essential))
(save-match-data
(when (and p (processp p)) (delete-process p))
(if (zerop (length device))

4
lisp/net/tramp-gvfs.el
View file

@ -1787,6 +1787,10 @@ This is relevant for GNOME Online Accounts."
"Maybe open a connection VEC.
Does not do anything if a connection is already open, but re-opens the
connection if a previous connection has died for some reason."
;; During completion, don't reopen a new connection.
(unless (tramp-connectable-p vec)
(throw 'non-essential 'non-essential))
;; We set the file name, in case there are incoming D-Bus signals or
;; D-Bus errors.
(setq tramp-gvfs-dbus-event-vector vec)

13
lisp/net/tramp-rclone.el
View file

@ -520,19 +520,14 @@ file names."
"Maybe open a connection VEC.
Does not do anything if a connection is already open, but re-opens the
connection if a previous connection has died for some reason."
;; During completion, don't reopen a new connection.
(unless (tramp-connectable-p vec)
(throw 'non-essential 'non-essential))
(let ((host (tramp-file-name-host vec)))
(when (rassoc `(,host) (tramp-rclone-parse-device-names nil))
(if (zerop (length host))
(tramp-error vec 'file-error "Storage %s not connected" host))
;; During completion, don't reopen a new connection. We check
;; this for the process related to `tramp-buffer-name';
;; otherwise `start-file-process' wouldn't run ever when
;; `non-essential' is non-nil.
(when (and (tramp-completion-mode-p)
(null (get-process (tramp-buffer-name vec))))
(throw 'non-essential 'non-essential))
;; We need a process bound to the connection buffer. Therefore,
;; we create a dummy process. Maybe there is a better solution?
(unless (get-buffer-process (tramp-get-connection-buffer vec))

45
lisp/net/tramp-sh.el
View file

@ -525,7 +525,9 @@ based on the Tramp and Emacs versions, and should not be set here."
:type '(repeat string))
;;;###tramp-autoload
(defcustom tramp-sh-extra-args '(("/bash\\'" . "-norc -noprofile"))
(defcustom tramp-sh-extra-args
'(("/bash\\'" . "-norc -noprofile")
("/zsh\\'" . "-f +Z"))
"Alist specifying extra arguments to pass to the remote shell.
Entries are (REGEXP . ARGS) where REGEXP is a regular expression
matching the shell file name and ARGS is a string specifying the
@ -1198,18 +1200,22 @@ component is used as the target of the symlink."
(defun tramp-sh-handle-file-exists-p (filename)
"Like `file-exists-p' for Tramp files."
(with-parsed-tramp-file-name filename nil
(with-tramp-file-property v localname "file-exists-p"
(or (not (null (tramp-get-file-property
v localname "file-attributes-integer" nil)))
(not (null (tramp-get-file-property
v localname "file-attributes-string" nil)))
(tramp-send-command-and-check
v
(format
"%s %s"
(tramp-get-file-exists-command v)
(tramp-shell-quote-argument localname)))))))
;; `file-exists-p' is used as predicate in file name completion.
;; We don't want to run it when `non-essential' is t, or there is
;; no connection process yet.
(when (tramp-connectable-p filename)
(with-parsed-tramp-file-name filename nil
(with-tramp-file-property v localname "file-exists-p"
(or (not (null (tramp-get-file-property
v localname "file-attributes-integer" nil)))
(not (null (tramp-get-file-property
v localname "file-attributes-string" nil)))
(tramp-send-command-and-check
v
(format
"%s %s"
(tramp-get-file-exists-command v)
(tramp-shell-quote-argument localname))))))))
(defun tramp-sh-handle-file-attributes (filename &optional id-format)
"Like `file-attributes' for Tramp files."
@ -4762,6 +4768,10 @@ If there is just some editing, retry it after 5 seconds."
"Maybe open a connection VEC.
Does not do anything if a connection is already open, but re-opens the
connection if a previous connection has died for some reason."
;; During completion, don't reopen a new connection.
(unless (tramp-connectable-p vec)
(throw 'non-essential 'non-essential))
(let ((p (tramp-get-connection-process vec))
(process-name (tramp-get-connection-property vec "process-name" nil))
(process-environment (copy-sequence process-environment))
@ -4806,15 +4816,6 @@ connection if a previous connection has died for some reason."
;; New connection must be opened.
(condition-case err
(unless (process-live-p p)
;; During completion, don't reopen a new connection. We
;; check this for the process related to
;; `tramp-buffer-name'; otherwise `start-file-process'
;; wouldn't run ever when `non-essential' is non-nil.
(when (and (tramp-completion-mode-p)
(null (get-process (tramp-buffer-name vec))))
(throw 'non-essential 'non-essential))
(with-tramp-progress-reporter
vec 3
(if (zerop (length (tramp-file-name-user vec)))

67
lisp/net/tramp-smb.el
View file

@ -832,12 +832,12 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
"Implement `file-attributes' for Tramp files using stat command."
(tramp-message
vec 5 "file attributes with stat: %s" (tramp-file-name-localname vec))
(with-current-buffer (tramp-get-connection-buffer vec)
(let* (size id link uid gid atime mtime ctime mode inode)
(when (tramp-smb-send-command
vec (format "stat \"%s\"" (tramp-smb-get-localname vec)))
(let* (size id link uid gid atime mtime ctime mode inode)
(when (tramp-smb-send-command
vec (format "stat \"%s\"" (tramp-smb-get-localname vec)))
;; Loop the listing.
;; Loop the listing.
(with-current-buffer (tramp-get-connection-buffer vec)
(goto-char (point-min))
(unless (re-search-forward tramp-smb-errors nil t)
(while (not (eobp))
@ -1628,40 +1628,40 @@ Result is a list of (LOCALNAME MODE SIZE MONTH DAY TIME YEAR)."
(with-parsed-tramp-file-name (file-name-as-directory directory) nil
(setq localname (or localname "/"))
(with-tramp-file-property v localname "file-entries"
(with-current-buffer (tramp-get-connection-buffer v)
(let* ((share (tramp-smb-get-share v))
(cache (tramp-get-connection-property v "share-cache" nil))
res entry)
(let* ((share (tramp-smb-get-share v))
(cache (tramp-get-connection-property v "share-cache" nil))
res entry)
(if (and (not share) cache)
;; Return cached shares.
(setq res cache)
(if (and (not share) cache)
;; Return cached shares.
(setq res cache)
;; Read entries.
(if share
(tramp-smb-send-command
v (format "dir \"%s*\"" (tramp-smb-get-localname v)))
;; `tramp-smb-maybe-open-connection' lists also the share names.
(tramp-smb-maybe-open-connection v))
;; Read entries.
(if share
(tramp-smb-send-command
v (format "dir \"%s*\"" (tramp-smb-get-localname v)))
;; `tramp-smb-maybe-open-connection' lists also the share names.
(tramp-smb-maybe-open-connection v))
;; Loop the listing.
;; Loop the listing.
(with-current-buffer (tramp-get-connection-buffer v)
(goto-char (point-min))
(if (re-search-forward tramp-smb-errors nil t)
(tramp-error v 'file-error "%s `%s'" (match-string 0) directory)
(while (not (eobp))
(setq entry (tramp-smb-read-file-entry share))
(forward-line)
(when entry (push entry res))))
(when entry (push entry res)))))
;; Cache share entries.
(unless share
(tramp-set-connection-property v "share-cache" res)))
;; Cache share entries.
(unless share
(tramp-set-connection-property v "share-cache" res)))
;; Add directory itself.
(push '("" "drwxrwxrwx" 0 (0 0)) res)
;; Add directory itself.
(push '("" "drwxrwxrwx" 0 (0 0)) res)
;; Return entries.
(delq nil res))))))
;; Return entries.
(delq nil res)))))
;; Return either a share name (if SHARE is nil), or a file name.
;;
@ -1855,6 +1855,10 @@ Does not do anything if a connection is already open, but re-opens the
connection if a previous connection has died for some reason.
If ARGUMENT is non-nil, use it as argument for
`tramp-smb-winexe-program', and suppress any checks."
;; During completion, don't reopen a new connection.
(unless (tramp-connectable-p vec)
(throw 'non-essential 'non-essential))
(let* ((share (tramp-smb-get-share vec))
(buf (tramp-get-connection-buffer vec))
(p (get-buffer-process buf)))
@ -1909,15 +1913,6 @@ If ARGUMENT is non-nil, use it as argument for
(string-equal
share
(tramp-get-connection-property p "smb-share" ""))))
;; During completion, don't reopen a new connection. We
;; check this for the process related to
;; `tramp-buffer-name'; otherwise `start-file-process'
;; wouldn't run ever when `non-essential' is non-nil.
(when (and (tramp-completion-mode-p)
(null (get-process (tramp-buffer-name vec))))
(throw 'non-essential 'non-essential))
(save-match-data
;; There might be unread output from checking for share names.
(when buf (with-current-buffer buf (erase-buffer)))

25
lisp/net/tramp-sudoedit.el
View file

@ -424,10 +424,14 @@ the result will be a local, non-Tramp, file name."
(defun tramp-sudoedit-handle-file-exists-p (filename)
"Like `file-exists-p' for Tramp files."
(with-parsed-tramp-file-name filename nil
(with-tramp-file-property v localname "file-exists-p"
(tramp-sudoedit-send-command
v "test" "-e" (tramp-compat-file-name-unquote localname)))))
;; `file-exists-p' is used as predicate in file name completion.
;; We don't want to run it when `non-essential' is t, or there is
;; no connection process yet.
(when (tramp-connectable-p filename)
(with-parsed-tramp-file-name filename nil
(with-tramp-file-property v localname "file-exists-p"
(tramp-sudoedit-send-command
v "test" "-e" (tramp-compat-file-name-unquote localname))))))
(defun tramp-sudoedit-handle-file-name-all-completions (filename directory)
"Like `file-name-all-completions' for Tramp files."
@ -760,18 +764,13 @@ Remove unneeded output."
"Maybe open a connection VEC.
Does not do anything if a connection is already open, but re-opens the
connection if a previous connection has died for some reason."
;; During completion, don't reopen a new connection.
(unless (tramp-connectable-p vec)
(throw 'non-essential 'non-essential))
;; We need a process bound to the connection buffer. Therefore, we
;; create a dummy process. Maybe there is a better solution?
(unless (tramp-get-connection-process vec)
;; During completion, don't reopen a new connection. We check
;; this for the process related to `tramp-buffer-name'; otherwise
;; `start-file-process' wouldn't run ever when `non-essential' is
;; non-nil.
(when (and (tramp-completion-mode-p)
(null (get-process (tramp-buffer-name vec))))
(throw 'non-essential 'non-essential))
(let ((p (make-network-process
:name (tramp-get-connection-name vec)
:buffer (tramp-get-connection-buffer vec)

69
lisp/net/tramp.el
View file

@ -1566,25 +1566,27 @@ necessary only. This function will be used in file name completion."
tramp-postfix-host-format))
(when localname localname)))
(defun tramp-get-buffer (vec)
(defun tramp-get-buffer (vec &optional dont-create)
"Get the connection buffer to be used for VEC."
(or (get-buffer (tramp-buffer-name vec))
(with-current-buffer (get-buffer-create (tramp-buffer-name vec))
;; We use the existence of connection property "process-buffer"
;; as indication, whether a connection is active.
(tramp-set-connection-property
vec "process-buffer"
(tramp-get-connection-property vec "process-buffer" nil))
(setq buffer-undo-list t
default-directory (tramp-make-tramp-file-name vec 'noloc 'nohop))
(current-buffer))))
(unless dont-create
(with-current-buffer (get-buffer-create (tramp-buffer-name vec))
;; We use the existence of connection property "process-buffer"
;; as indication, whether a connection is active.
(tramp-set-connection-property
vec "process-buffer"
(tramp-get-connection-property vec "process-buffer" nil))
(setq buffer-undo-list t
default-directory
(tramp-make-tramp-file-name vec 'noloc 'nohop))
(current-buffer)))))
(defun tramp-get-connection-buffer (vec)
(defun tramp-get-connection-buffer (vec &optional dont-create)
"Get the connection buffer to be used for VEC.
In case a second asynchronous communication has been started, it is different
from `tramp-get-buffer'."
(or (tramp-get-connection-property vec "process-buffer" nil)
(tramp-get-buffer vec)))
(tramp-get-buffer vec dont-create)))
(defun tramp-get-connection-name (vec)
"Get the connection name to be used for VEC.
@ -1770,14 +1772,15 @@ applicable)."
;; Log only when there is a minimum level.
(when (>= tramp-verbose 4)
(let ((tramp-verbose 0))
;; Append connection buffer for error messages.
;; Append connection buffer for error messages, if exists.
(when (= level 1)
(with-current-buffer
(if (processp vec-or-proc)
(process-buffer vec-or-proc)
(tramp-get-connection-buffer vec-or-proc))
(setq fmt-string (concat fmt-string "\n%s")
arguments (append arguments (list (buffer-string))))))
(ignore-errors
(with-current-buffer
(if (processp vec-or-proc)
(process-buffer vec-or-proc)
(tramp-get-connection-buffer vec-or-proc 'dont-create))
(setq fmt-string (concat fmt-string "\n%s")
arguments (append arguments (list (buffer-string)))))))
;; Translate proc to vec.
(when (processp vec-or-proc)
(setq vec-or-proc (process-get vec-or-proc 'vector))))
@ -2517,16 +2520,21 @@ Add operations defined in `HANDLER-alist' to `tramp-file-name-handler'."
;; This variable has been obsoleted in Emacs 26.
tramp-completion-mode))
(defun tramp-connectable-p (filename)
(defun tramp-connectable-p (vec-or-filename)
"Check, whether it is possible to connect the remote host w/o side-effects.
This is true, if either the remote host is already connected, or if we are
not in completion mode."
(let (tramp-verbose)
(and (tramp-tramp-file-p filename)
(or (not (tramp-completion-mode-p))
(process-live-p
(tramp-get-connection-process
(tramp-dissect-file-name filename)))))))
(let (tramp-verbose
(vec
(cond
((tramp-file-name-p vec-or-filename) vec-or-filename)
((tramp-tramp-file-p vec-or-filename)
(tramp-dissect-file-name vec-or-filename)))))
(or ;; We check this for the process related to
;; `tramp-buffer-name'; otherwise `start-file-process'
;; wouldn't run ever when `non-essential' is non-nil.
(and vec (process-live-p (get-process (tramp-buffer-name vec))))
(not (tramp-completion-mode-p)))))
;; Method, host name and user name completion.
;; `tramp-completion-dissect-file-name' returns a list of
@ -2606,8 +2614,7 @@ not in completion mode."
(try-completion
filename
(mapcar #'list (file-name-all-completions filename directory))
(when (and predicate
(tramp-connectable-p (expand-file-name filename directory)))
(when (and predicate (tramp-connectable-p directory))
(lambda (x) (funcall predicate (expand-file-name (car x) directory))))))
;; I misuse a little bit the `tramp-file-name' structure in order to
@ -3096,7 +3103,11 @@ User is always nil."
(defun tramp-handle-file-exists-p (filename)
"Like `file-exists-p' for Tramp files."
(not (null (file-attributes filename))))
;; `file-exists-p' is used as predicate in file name completion.
;; We don't want to run it when `non-essential' is t, or there is
;; no connection process yet.
(when (tramp-connectable-p filename)
(not (null (file-attributes filename)))))
(defun tramp-handle-file-in-directory-p (filename directory)
"Like `file-in-directory-p' for Tramp files."

49
lisp/play/gamegrid.el
View file

@ -505,9 +505,12 @@ format."
;; ;;;;;;;;;;;;;;; high score functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun gamegrid-add-score (file score)
(defun gamegrid-add-score (file score &optional reverse)
"Add the current score to the high score file.
If REVERSE is non-nil, treat lower scores as better than higher
scores. This is useful for games where lower scores are better.
On POSIX systems there may be a shared game directory for all users in
which the scorefiles are kept. On such systems Emacs doesn't create
the score file FILE in this directory, if it doesn't already exist.
@ -525,9 +528,9 @@ specified by the variable `temporary-file-directory'. If necessary,
FILE is created there."
(pcase system-type
((or 'ms-dos 'windows-nt)
(gamegrid-add-score-insecure file score))
(gamegrid-add-score-insecure file score reverse))
(_
(gamegrid-add-score-with-update-game-score file score))))
(gamegrid-add-score-with-update-game-score file score reverse))))
;; On POSIX systems there are four cases to distinguish:
@ -556,20 +559,21 @@ FILE is created there."
(defvar gamegrid-shared-game-dir)
(defun gamegrid-add-score-with-update-game-score (file score)
(defun gamegrid-add-score-with-update-game-score (file score &optional reverse)
(let* ((update-game-score-modes
(file-modes (expand-file-name "update-game-score" exec-directory)))
(gamegrid-shared-game-dir
(not (zerop (logand #o6000 (or update-game-score-modes 0))))))
(cond ((or (not update-game-score-modes) (file-name-absolute-p file))
(gamegrid-add-score-insecure file score
gamegrid-user-score-file-directory))
gamegrid-user-score-file-directory
reverse))
((and gamegrid-shared-game-dir
(file-exists-p (expand-file-name file shared-game-score-directory)))
;; Use the setgid (or setuid) "update-game-score" program
;; to update a system-wide score file.
(gamegrid-add-score-with-update-game-score-1 file
(expand-file-name file shared-game-score-directory) score))
(expand-file-name file shared-game-score-directory) score reverse))
;; Else: Add the score to a score file in the user's home
;; directory.
(gamegrid-shared-game-dir
@ -579,7 +583,8 @@ FILE is created there."
(directory-file-name gamegrid-user-score-file-directory))
(make-directory gamegrid-user-score-file-directory t))
(gamegrid-add-score-insecure file score
gamegrid-user-score-file-directory))
gamegrid-user-score-file-directory
reverse))
(t
(unless (file-exists-p
(directory-file-name gamegrid-user-score-file-directory))
@ -588,9 +593,9 @@ FILE is created there."
gamegrid-user-score-file-directory)))
(unless (file-exists-p f)
(write-region "" nil f nil 'silent nil 'excl))
(gamegrid-add-score-with-update-game-score-1 file f score))))))
(gamegrid-add-score-with-update-game-score-1 file f score reverse))))))
(defun gamegrid-add-score-with-update-game-score-1 (file target score)
(defun gamegrid-add-score-with-update-game-score-1 (file target score &optional reverse)
(let ((default-directory "/")
(errbuf (generate-new-buffer " *update-game-score loss*"))
(marker-string (concat
@ -601,17 +606,16 @@ FILE is created there."
(with-local-quit
(apply
'call-process
(append
(list
(expand-file-name "update-game-score" exec-directory)
nil errbuf nil
"-m" (int-to-string gamegrid-score-file-length)
"-d" (if gamegrid-shared-game-dir
(expand-file-name shared-game-score-directory)
(file-name-directory target))
file
(int-to-string score)
marker-string))))
`(,(expand-file-name "update-game-score" exec-directory)
nil ,errbuf nil
"-m" ,(int-to-string gamegrid-score-file-length)
"-d" ,(if gamegrid-shared-game-dir
(expand-file-name shared-game-score-directory)
(file-name-directory target))
,@(if reverse '("-r"))
,file
,(int-to-string score)
,marker-string)))
(if (buffer-modified-p errbuf)
(progn
(display-buffer errbuf)
@ -632,7 +636,7 @@ FILE is created there."
marker-string) nil t)
(beginning-of-line)))))
(defun gamegrid-add-score-insecure (file score &optional directory)
(defun gamegrid-add-score-insecure (file score &optional directory reverse)
(save-excursion
(setq file (expand-file-name file (or directory
temporary-file-directory)))
@ -645,7 +649,8 @@ FILE is created there."
(user-full-name)
user-mail-address))
(sort-fields 1 (point-min) (point-max))
(reverse-region (point-min) (point-max))
(unless reverse
(reverse-region (point-min) (point-max)))
(goto-char (point-min))
(forward-line gamegrid-score-file-length)
(delete-region (point) (point-max))

8
lisp/progmodes/python.el
View file

@ -4084,6 +4084,12 @@ JUSTIFY should be used (if applicable) as in `fill-paragraph'."
(goto-char (line-end-position))))
t)
(defun python-do-auto-fill ()
"Like `do-auto-fill', but bind `fill-indent-according-to-mode'."
;; See Bug#36056.
(let ((fill-indent-according-to-mode t))
(do-auto-fill)))
;;; Skeletons
@ -5379,7 +5385,7 @@ REPORT-FN is Flymake's callback function."
(set (make-local-variable 'paragraph-start) "\\s-*$")
(set (make-local-variable 'fill-paragraph-function)
#'python-fill-paragraph)
(set (make-local-variable 'fill-indent-according-to-mode) t) ; Bug#36056.
(set (make-local-variable 'normal-auto-fill-function) #'python-do-auto-fill)
(set (make-local-variable 'beginning-of-defun-function)
#'python-nav-beginning-of-defun)

46
lisp/progmodes/sh-script.el
View file

@ -112,7 +112,7 @@
;; would make this unnecessary; simply learn the values when you visit
;; the buffer.
;; You can do this automatically like this:
;; (add-hook 'sh-set-shell-hook 'sh-learn-buffer-indent)
;; (add-hook 'sh-set-shell-hook #'sh-learn-buffer-indent)
;;
;; However... `sh-learn-buffer-indent' is extremely slow,
;; especially on large-ish buffer. Also, if there are conflicts the
@ -480,7 +480,6 @@ This is buffer-local in every such buffer.")
(define-key map "\C-c>" 'sh-learn-buffer-indent)
(define-key map "\C-c\C-\\" 'sh-backslash-region)
(define-key map "=" 'sh-assignment)
(define-key map "\C-c+" 'sh-add)
(define-key map "\C-\M-x" 'sh-execute-region)
(define-key map "\C-c\C-x" 'executable-interpret)
@ -1059,7 +1058,7 @@ subshells can nest."
(when (< startpos (line-beginning-position))
(put-text-property startpos (point) 'syntax-multiline t)
(add-hook 'syntax-propertize-extend-region-functions
'syntax-propertize-multiline nil t))
#'syntax-propertize-multiline nil t))
)))
@ -1603,25 +1602,25 @@ with your script for an edit-interpret-debug cycle."
(setq-local local-abbrev-table sh-mode-abbrev-table)
(setq-local comint-dynamic-complete-functions
sh-dynamic-complete-functions)
(add-hook 'completion-at-point-functions 'comint-completion-at-point nil t)
(add-hook 'completion-at-point-functions #'comint-completion-at-point nil t)
;; we can't look if previous line ended with `\'
(setq-local comint-prompt-regexp "^[ \t]*")
(setq-local imenu-case-fold-search nil)
(setq font-lock-defaults
'((sh-font-lock-keywords
`((sh-font-lock-keywords
sh-font-lock-keywords-1 sh-font-lock-keywords-2)
nil nil
((?/ . "w") (?~ . "w") (?. . "w") (?- . "w") (?_ . "w")) nil
(font-lock-syntactic-face-function
. sh-font-lock-syntactic-face-function)))
. ,#'sh-font-lock-syntactic-face-function)))
(setq-local syntax-propertize-function #'sh-syntax-propertize-function)
(add-hook 'syntax-propertize-extend-region-functions
#'syntax-propertize-multiline 'append 'local)
(setq-local skeleton-pair-alist '((?` _ ?`)))
(setq-local skeleton-pair-filter-function 'sh-quoted-p)
(setq-local skeleton-pair-filter-function #'sh-quoted-p)
(setq-local skeleton-further-elements
'((< '(- (min sh-basic-offset (current-column))))))
(setq-local skeleton-filter-function 'sh-feature)
(setq-local skeleton-filter-function #'sh-feature)
(setq-local skeleton-newline-indent-rigidly t)
(setq-local defun-prompt-regexp
(concat
@ -2408,12 +2407,12 @@ whose value is the shell name (don't quote it)."
(message "setting up indent stuff")
;; sh-mode has already made indent-line-function local
;; but do it in case this is called before that.
(setq-local indent-line-function 'sh-indent-line))
(setq-local indent-line-function #'sh-indent-line))
(if sh-make-vars-local
(sh-make-vars-local))
(message "Indentation setup for shell type %s" sh-shell))
(message "No indentation for this shell type.")
(setq-local indent-line-function 'sh-basic-indent-line))
(setq-local indent-line-function #'sh-basic-indent-line))
(when font-lock-mode
(setq font-lock-set-defaults nil)
(font-lock-set-defaults)
@ -3586,7 +3585,7 @@ so that `occur-next' and `occur-prev' will work."
;; (insert ")\n")
;; )))
;;
;; (add-hook 'sh-learned-buffer-hook 'what-i-learned)
;; (add-hook 'sh-learned-buffer-hook #'what-i-learned)
;; Originally this was sh-learn-region-indent (beg end)
@ -4055,7 +4054,8 @@ Add these variables to `sh-shell-variables'."
(goto-char (point-min))
(setq sh-shell-variables-initialized t)
(while (search-forward "=" nil t)
(sh-assignment 0)))
(sh--assignment-collect)))
(add-hook 'post-self-insert-hook #'sh--assignment-collect nil t)
(message "Scanning buffer `%s' for variable assignments...done"
(buffer-name)))
@ -4328,20 +4328,24 @@ option followed by a colon `:' if the option accepts an argument."
(put 'sh-assignment 'delete-selection t)
(defun sh-assignment (arg)
"Remember preceding identifier for future completion and do self-insert."
(interactive "p")
(declare (obsolete nil "27.1"))
(self-insert-command arg)
(if (<= arg 1)
(sh-remember-variable
(save-excursion
(if (re-search-forward (sh-feature sh-assignment-regexp)
(prog1 (point)
(beginning-of-line 1))
t)
(match-string 1))))))
(sh--assignment-collect))
(defun sh--assignment-collect ()
(sh-remember-variable
(when (eq ?= (char-before))
(save-excursion
(if (re-search-forward (sh-feature sh-assignment-regexp)
(prog1 (point)
(beginning-of-line 1))
t)
(match-string 1))))))
(put 'sh-assignment 'delete-selection t)
(defun sh-maybe-here-document (arg)
"Insert self. Without prefix, following unquoted `<' inserts here document.

14
lisp/replace.el
View file

@ -2698,7 +2698,7 @@ characters."
(num-replacements 0)
(nocasify t) ; Undo must preserve case (Bug#31073).
search-string
next-replacement)
last-replacement)
(while (and (< stack-idx stack-len)
stack
(or (null replaced) last-was-act-and-show))
@ -2709,9 +2709,9 @@ characters."
;; Bind swapped values
;; (search-string <--> replacement)
search-string (nth (if replaced 4 3) elt)
next-replacement (nth (if replaced 3 4) elt)
last-replacement (nth (if replaced 3 4) elt)
search-string-replaced search-string
next-replacement-replaced next-replacement
next-replacement-replaced last-replacement
last-was-act-and-show nil)
(when (and (= stack-idx stack-len)
@ -2733,16 +2733,18 @@ characters."
(match-data t (nth 2 elt)))
noedit
(replace-match-maybe-edit
next-replacement nocasify literal
last-replacement nocasify literal
noedit real-match-data backward)
replace-count (1- replace-count)
real-match-data
(save-excursion
(goto-char (match-beginning 0))
(if regexp-flag
(looking-at next-replacement)
(looking-at (regexp-quote next-replacement)))
(looking-at last-replacement)
(looking-at (regexp-quote last-replacement)))
(match-data t (nth 2 elt))))
(when regexp-flag
(setq next-replacement (nth 4 elt)))
;; Set replaced nil to keep in loop
(when (eq def 'undo-all)
(setq replaced nil

9
lisp/select.el
View file

@ -160,12 +160,11 @@ The value nil is the same as the list (UTF8_STRING COMPOUND_TEXT STRING)."
(const TEXT)))
:group 'killing)
;; Get a selection value of type TYPE by calling gui-get-selection with
;; an appropriate DATA-TYPE argument decided by `x-select-request-type'.
;; The return value is already decoded. If gui-get-selection causes an
;; error, this function return nil.
(defun gui--selection-value-internal (type)
"Get a selection value of type TYPE.
Call `gui-get-selection' with an appropriate DATA-TYPE argument
decided by `x-select-request-type'. The return value is already
decoded. If `gui-get-selection' signals an error, return nil."
(let ((request-type (if (eq window-system 'x)
(or x-select-request-type
'(UTF8_STRING COMPOUND_TEXT STRING))

6
lisp/server.el
View file

@ -563,9 +563,9 @@ See variable `server-auth-dir' for details."
(format "it is not owned by you (owner = %s (%d))"
(user-full-name uid) uid))
(w32 nil) ; on NTFS?
((/= 0 (logand ?\077 (file-modes dir)))
(format "it is accessible by others (%03o)"
(file-modes dir)))
((let ((modes (file-modes dir)))
(unless (zerop (logand (or modes 0) #o077))
(format "it is accessible by others (%03o)" modes))))
(t nil))))
(when unsafe
(error "`%s' is not a safe directory because %s"

16
lisp/shadowfile.el
View file

@ -207,7 +207,7 @@ PREFIX."
;;; I use the term `site' to refer to a string which may be the
;;; cluster identification "/name:", a remote identification
;;; "/method:user@host:", or "/system-name:' (the value of
;;; "/method:user@host:", or "/system-name:" (the value of
;;; `shadow-system-name') for the location of local files. All
;;; user-level commands should accept either.
@ -607,6 +607,11 @@ and to are absolute file names."
canonical-file shadow-literal-groups nil)
(shadow-shadows-of-1
canonical-file shadow-regexp-groups t)))))
(when shadow-debug
(message
"shadow-shadows-of: %s %s %s %s %s"
file (shadow-local-file file) shadow-homedir
absolute-file canonical-file))
(set (intern file shadow-hashtable) shadows))))
(defun shadow-shadows-of-1 (file groups regexp)
@ -621,6 +626,10 @@ Consider them as regular expressions if third arg REGEXP is true."
(let ((realname
(tramp-file-name-localname
(shadow-parse-name file))))
(when shadow-debug
(message
"shadow-shadows-of-1: %s %s %s"
file (shadow-parse-name file) realname))
(mapcar
(function
(lambda (x)
@ -631,6 +640,11 @@ Consider them as regular expressions if third arg REGEXP is true."
(defun shadow-add-to-todo ()
"If current buffer has shadows, add them to the list needing to be copied."
(when shadow-debug
(message
"shadow-add-to-todo: %s %s"
(buffer-file-name (current-buffer))
(shadow-expand-file-name (buffer-file-name (current-buffer)))))
(let ((shadows (shadow-shadows-of
(shadow-expand-file-name
(buffer-file-name (current-buffer))))))

1
lisp/startup.el
View file

@ -406,6 +406,7 @@ if you have not already set `auto-save-list-file-name' yourself.
Directories in the prefix will be created if necessary.
Set this to nil if you want to prevent `auto-save-list-file-name'
from being initialized."
:initialize #'custom-initialize-delay
:type '(choice (const :tag "Don't record a session's auto save list" nil)
string)
:group 'auto-save)

2
lisp/subr.el
View file

@ -2045,7 +2045,7 @@ Uses the `derived-mode-parent' property of the symbol to trace backwards."
(put 'major-mode--suspended 'permanent-local t)
(defun major-mode-suspend ()
"Exit current major, remembering it."
"Exit current major mode, remembering it."
(let* ((prev-major-mode (or major-mode--suspended
(unless (eq major-mode 'fundamental-mode)
major-mode))))

130
lisp/term/w32-win.el
View file

@ -485,6 +485,136 @@ numbers, and the build number."
That includes all Windows systems except for 9X/Me."
(getenv "SystemRoot"))
;; The value of the following variable was calculated using the table in
;; https://docs.microsoft.com/windows/desktop/Intl/unicode-subset-bitfields,
;; by looking for Unicode subranges for which no USB bits are defined.
(defconst w32-no-usb-subranges
'((#x000800 . #x0008ff)
(#x0018b0 . #x0018ff)
(#x001a20 . #x001aff)
(#x001bc0 . #x001bff)
(#x001c80 . #x001cff)
(#x002fe0 . #x002fef)
(#x00a4d0 . #x00a4ff)
(#x00a6a0 . #x00a6ff)
(#x00a830 . #x00a83f)
(#x00a8e0 . #x00a8ff)
(#x00a960 . #x00a9ff)
(#x00aa60 . #x00abff)
(#x00d7b0 . #x00d7ff)
(#x010200 . #x01027f)
(#x0102e0 . #x0102ff)
(#x010350 . #x01037f)
(#x0103e0 . #x0103ff)
(#x0104b0 . #x0107ff)
(#x010840 . #x0108ff)
(#x010940 . #x0109ff)
(#x010a60 . #x011fff)
(#x012480 . #x01cfff)
(#x01d250 . #x01d2ff)
(#x01d380 . #x01d3ff)
(#x01d800 . #x01efff)
(#x01f0a0 . #x01ffff)
(#x02a6e0 . #x02f7ff)
(#x02fa20 . #x0dffff)
(#x0e0080 . #x0e00ff)
(#x0e01f0 . #x0fefff))
"List of Unicode subranges whose support cannot be announced by a font.
The FONTSIGNATURE structure reported by MS-Windows for a font
includes 123 Unicode Subset bits (USBs) to identify subranges of
the Unicode codepoint space supported by the font. Since the
number of bits is fixed, not every Unicode block can have a
corresponding USB bit; fonts that support characters from blocks
that have no USBs cannot communicate their support to Emacs,
unless the font is opened and physically tested for glyphs for
characters from these blocks.")
(defun w32--filter-USB-scripts ()
"Filter USB scripts out of `script-representative-chars'."
(let (val)
(dolist (elt script-representative-chars)
(let ((subranges w32-no-usb-subranges)
(chars (cdr elt))
ch found subrange)
(while (and (consp chars) (not found))
(setq ch (car chars)
chars (cdr chars))
(while (and (consp subranges) (not found))
(setq subrange (car subranges)
subranges (cdr subranges))
(when (and (>= ch (car subrange)) (<= ch (cdr subrange)))
(setq found t)
(push elt val))))))
(nreverse val)))
(defvar w32-non-USB-fonts nil
"Alist of script symbols and corresponding fonts.
Each element of the alist has the form (SCRIPT FONTS...), where
SCRIPT is a symbol of a script and FONTS are one or more fonts installed
on the system that can display SCRIPT's characters. FONTS are
specified as symbols.
Only scripts that have no corresponding Unicode Subset Bits (USBs) can
be found in this alist.
This alist is used by w32font.c when it looks for fonts that can display
characters from scripts for which no USBs are defined.")
(defun w32-find-non-USB-fonts (&optional frame size)
"Compute the value of `w32-non-USB-fonts' for specified SIZE and FRAME.
FRAME defaults to the selected frame.
SIZE is the required font size and defaults to the nominal size of the
default font on FRAME, or its best approximation."
(let* ((inhibit-compacting-font-caches t)
(all-fonts
(delete-dups
(x-list-fonts "-*-*-medium-r-normal-*-*-*-*-*-*-iso10646-1"
'default frame)))
val)
(mapc (function
(lambda (script-desc)
(let* ((script (car script-desc))
(script-chars (vconcat (cdr script-desc)))
(nchars (length script-chars))
(fntlist all-fonts)
(entry (list script))
fspec ffont font-obj glyphs idx)
;; For each font in FNTLIST, determine whether it
;; supports the representative character(s) of any
;; scripts that have no USBs defined for it.
(dolist (fnt fntlist)
(setq fspec (ignore-errors (font-spec :name fnt)))
(if fspec
(setq ffont (find-font fspec frame)))
(when ffont
(setq font-obj
(open-font ffont size frame))
;; Ignore fonts for which open-font returns nil:
;; they are buggy fonts that we cannot use anyway.
(setq glyphs
(if font-obj
(font-get-glyphs font-obj
0 nchars script-chars)
'[nil]))
;; Does this font support ALL of the script's
;; representative characters?
(setq idx 0)
(while (and (< idx nchars) (not (null (aref glyphs idx))))
(setq idx (1+ idx)))
(if (= idx nchars)
;; It does; add this font to the script's entry in alist.
(let ((font-family (font-get font-obj :family)))
;; Unifont is an ugly font, and it is already
;; present in the default fontset.
(unless (string= (downcase (symbol-name font-family))
"unifont")
(push font-family entry))))))
(if (> (length entry) 1)
(push (nreverse entry) val)))))
(w32--filter-USB-scripts))
;; We've opened a lot of fonts, so clear the font caches to free
;; some memory.
(clear-font-cache)
(and val (setq w32-non-USB-fonts val))))
(provide 'w32-win)
(provide 'term/w32-win)

4
lisp/textmodes/table.el
View file

@ -567,10 +567,6 @@
;; Consider the use of `:box' face attribute under Emacs 21
;; Consider the use of `modification-hooks' text property instead of
;; rebinding the keymap
;; Maybe provide complete XEmacs support in the future however the
;; "extent" is the single largest obstacle lying ahead, read the
;; document in Emacs info.
;; (progn (require 'info) (Info-find-node "elisp" "Not Intervals"))
;;
;;
;; ---------------

5
lisp/tooltip.el
View file

@ -365,7 +365,10 @@ It is also called if Tooltip mode is on, for text-only displays."
(let ((message-log-max nil))
(message "%s" tooltip-previous-message)
(setq tooltip-previous-message nil)))
(t
;; Only stop displaying the message when the current message is our own.
;; This has the advantage of not clearing the echo area when
;; running after an error message was displayed (Bug#3192).
((equal-including-properties tooltip-help-message (current-message))
(message nil)))))
(defun tooltip-show-help (msg)

2
lisp/vc/vc-cvs.el
View file

@ -440,7 +440,7 @@ REV is the revision to check out."
(if vc-cvs-use-edit
(vc-cvs-command nil 0 file "unedit")
;; Make the file read-only by switching off all w-bits
(set-file-modes file (logand (file-modes file) 3950)))))
(set-file-modes file (logand (file-modes file) #o7555)))))
(defun vc-cvs-merge-file (file)
"Accept a file merge request, prompting for revisions."

16
lisp/vc/vc-dir.el
View file

@ -864,10 +864,18 @@ with the command \\[tags-loop-continue]."
delimited)
(fileloop-continue))
(defun vc-dir-ignore ()
"Ignore the current file."
(interactive)
(vc-ignore (vc-dir-current-file)))
(defun vc-dir-ignore (&optional arg)
"Ignore the current file.
If a prefix argument is given, ignore all marked files."
(interactive "P")
(if arg
(ewoc-map
(lambda (filearg)
(when (vc-dir-fileinfo->marked filearg)
(vc-ignore (vc-dir-fileinfo->name filearg))
t))
vc-ewoc)
(vc-ignore (vc-dir-current-file))))
(defun vc-dir-current-file ()
(let ((node (ewoc-locate vc-ewoc)))

5
lisp/vc/vc-svn.el
View file

@ -366,8 +366,9 @@ FILE is a file wildcard, relative to the root directory of DIRECTORY."
(defun vc-svn-ignore-completion-table (directory)
"Return the list of ignored files in DIRECTORY."
(with-temp-buffer
(vc-svn-command t t nil "propget" "svn:ignore" (expand-file-name directory))
(split-string (buffer-string))))
(when (zerop (vc-svn-command
t t nil "propget" "svn:ignore" (expand-file-name directory)))
(split-string (buffer-string) "\n"))))
(defun vc-svn-find-admin-dir (file)
"Return the administrative directory of FILE."

13
lisp/vc/vc.el
View file

@ -1417,17 +1417,22 @@ remove from the list of ignored files."
(defun vc-default-ignore (backend file &optional directory remove)
"Ignore FILE under the VCS of DIRECTORY (default is `default-directory').
FILE is a file wildcard, relative to the root directory of DIRECTORY.
FILE is a wildcard specification, either relative to
DIRECTORY or absolute.
When called from Lisp code, if DIRECTORY is non-nil, the
repository to use will be deduced by DIRECTORY; if REMOVE is
non-nil, remove FILE from ignored files.
Argument BACKEND is the backend you are using."
(let ((ignore
(vc-call-backend backend 'find-ignore-file (or directory default-directory)))
(pattern (file-relative-name
(expand-file-name file) (file-name-directory file))))
file-path root-dir pattern)
(setq file-path (expand-file-name file directory))
(setq root-dir (file-name-directory ignore))
(when (not (string= (substring file-path 0 (length root-dir)) root-dir))
(error "Ignore spec %s is not below project root %s" file-path root-dir))
(setq pattern (substring file-path (length root-dir)))
(if remove
(vc--remove-regexp pattern ignore)
(vc--remove-regexp (concat "^" (regexp-quote pattern ) "\\(\n\\|$\\)") ignore)
(vc--add-line pattern ignore))))
(defun vc-default-ignore-completion-table (backend file)

6
lisp/wid-browse.el
View file

@ -89,7 +89,11 @@ if that value is non-nil."
(defun widget-browse-at (pos)
"Browse the widget under point."
(interactive "d")
(let* ((field (get-char-property pos 'field))
(let* ((field (or
;; See comments in `widget-specify-field' to know why we
;; need this.
(get-char-property pos 'real-field)
(get-char-property pos 'field)))
(button (get-char-property pos 'button))
(doc (get-char-property pos 'widget-doc))
(text (cond (field "This is an editable text area.")

1
lisp/wid-edit.el
View file

@ -414,6 +414,7 @@ the :notify function can't know the new value.")
(defmacro widget-specify-insert (&rest form)
"Execute FORM without inheriting any text properties."
(declare (debug body))
`(save-restriction
(let ((inhibit-read-only t)
(inhibit-modification-hooks t))

203
src/alloc.c
View file

@ -224,7 +224,7 @@ struct emacs_globals globals;
/* maybe_gc collects garbage if this goes negative. */
intmax_t consing_until_gc;
EMACS_INT consing_until_gc;
#ifdef HAVE_PDUMPER
/* Number of finalizers run: used to loop over GC until we stop
@ -238,10 +238,17 @@ bool gc_in_progress;
/* System byte and object counts reported by GC. */
/* Assume byte counts fit in uintptr_t and object counts fit into
intptr_t. */
typedef uintptr_t byte_ct;
typedef intptr_t object_ct;
/* Number of live and free conses etc. */
/* Large-magnitude value for a threshold count, which fits in EMACS_INT.
Using only half the EMACS_INT range avoids overflow hassles.
There is no need to fit these counts into fixnums. */
#define HI_THRESHOLD (EMACS_INT_MAX / 2)
/* Number of live and free conses etc. counted by the most-recent GC. */
static struct gcstat
{
@ -299,7 +306,7 @@ static intptr_t garbage_collection_inhibited;
/* The GC threshold in bytes, the last time it was calculated
from gc-cons-threshold and gc-cons-percentage. */
static intmax_t gc_threshold;
static EMACS_INT gc_threshold;
/* If nonzero, this is a warning delivered by malloc and not yet
displayed. */
@ -536,6 +543,15 @@ XFLOAT_INIT (Lisp_Object f, double n)
XFLOAT (f)->u.data = n;
}
/* Account for allocation of NBYTES in the heap. This is a separate
function to avoid hassles with implementation-defined conversion
from unsigned to signed types. */
static void
tally_consing (ptrdiff_t nbytes)
{
consing_until_gc -= nbytes;
}
#ifdef DOUG_LEA_MALLOC
static bool
pointers_fit_in_lispobj_p (void)
@ -560,7 +576,7 @@ struct Lisp_Finalizer finalizers;
/* Head of a circularly-linked list of finalizers that must be invoked
because we deemed them unreachable. This list must be global, and
not a local inside garbage_collect_1, in case we GC again while
not a local inside garbage_collect, in case we GC again while
running finalizers. */
struct Lisp_Finalizer doomed_finalizers;
@ -1366,16 +1382,14 @@ make_interval (void)
newi->next = interval_block;
interval_block = newi;
interval_block_index = 0;
gcstat.total_free_intervals += INTERVAL_BLOCK_SIZE;
}
val = &interval_block->intervals[interval_block_index++];
}
MALLOC_UNBLOCK_INPUT;
consing_until_gc -= sizeof (struct interval);
tally_consing (sizeof (struct interval));
intervals_consed++;
gcstat.total_free_intervals--;
RESET_INTERVAL (val);
val->gcmarkbit = 0;
return val;
@ -1730,8 +1744,6 @@ allocate_string (void)
NEXT_FREE_LISP_STRING (s) = string_free_list;
string_free_list = ptr_bounds_clip (s, sizeof *s);
}
gcstat.total_free_strings += STRING_BLOCK_SIZE;
}
check_string_free_list ();
@ -1742,10 +1754,8 @@ allocate_string (void)
MALLOC_UNBLOCK_INPUT;
gcstat.total_free_strings--;
gcstat.total_strings++;
++strings_consed;
consing_until_gc -= sizeof *s;
tally_consing (sizeof *s);
#ifdef GC_CHECK_STRING_BYTES
if (!noninteractive)
@ -1865,7 +1875,7 @@ allocate_string_data (struct Lisp_String *s,
old_data->string = NULL;
}
consing_until_gc -= needed;
tally_consing (needed);
}
@ -2461,7 +2471,6 @@ make_float (double float_value)
memset (new->gcmarkbits, 0, sizeof new->gcmarkbits);
float_block = new;
float_block_index = 0;
gcstat.total_free_floats += FLOAT_BLOCK_SIZE;
}
XSETFLOAT (val, &float_block->floats[float_block_index]);
float_block_index++;
@ -2471,9 +2480,8 @@ make_float (double float_value)
XFLOAT_INIT (val, float_value);
eassert (!XFLOAT_MARKED_P (XFLOAT (val)));
consing_until_gc -= sizeof (struct Lisp_Float);
tally_consing (sizeof (struct Lisp_Float));
floats_consed++;
gcstat.total_free_floats--;
return val;
}
@ -2543,9 +2551,8 @@ free_cons (struct Lisp_Cons *ptr)
ptr->u.s.u.chain = cons_free_list;
ptr->u.s.car = dead_object ();
cons_free_list = ptr;
if (INT_ADD_WRAPV (consing_until_gc, sizeof *ptr, &consing_until_gc))
consing_until_gc = INTMAX_MAX;
gcstat.total_free_conses++;
ptrdiff_t nbytes = sizeof *ptr;
tally_consing (-nbytes);
}
DEFUN ("cons", Fcons, Scons, 2, 2, 0,
@ -2565,26 +2572,12 @@ DEFUN ("cons", Fcons, Scons, 2, 2, 0,
{
if (cons_block_index == CONS_BLOCK_SIZE)
{
/* Maximum number of conses that should be active at any
given time, so that list lengths fit into a ptrdiff_t and
into a fixnum. */
ptrdiff_t max_conses = min (PTRDIFF_MAX, MOST_POSITIVE_FIXNUM);
/* This check is typically optimized away, as a runtime
check is needed only on weird platforms where a count of
distinct conses might not fit. */
if (max_conses < INTPTR_MAX / sizeof (struct Lisp_Cons)
&& (max_conses - CONS_BLOCK_SIZE
< gcstat.total_free_conses + gcstat.total_conses))
memory_full (sizeof (struct cons_block));
struct cons_block *new
= lisp_align_malloc (sizeof *new, MEM_TYPE_CONS);
memset (new->gcmarkbits, 0, sizeof new->gcmarkbits);
new->next = cons_block;
cons_block = new;
cons_block_index = 0;
gcstat.total_free_conses += CONS_BLOCK_SIZE;
}
XSETCONS (val, &cons_block->conses[cons_block_index]);
cons_block_index++;
@ -2596,7 +2589,6 @@ DEFUN ("cons", Fcons, Scons, 2, 2, 0,
XSETCDR (val, cdr);
eassert (!XCONS_MARKED_P (XCONS (val)));
consing_until_gc -= sizeof (struct Lisp_Cons);
gcstat.total_free_conses--;
cons_cells_consed++;
return val;
}
@ -2855,7 +2847,6 @@ setup_on_free_list (struct Lisp_Vector *v, ptrdiff_t nbytes)
eassert (vindex < VECTOR_MAX_FREE_LIST_INDEX);
set_next_vector (v, vector_free_lists[vindex]);
vector_free_lists[vindex] = v;
gcstat.total_free_vector_slots += nbytes / word_size;
}
/* Get a new vector block. */
@ -2903,7 +2894,6 @@ allocate_vector_from_block (ptrdiff_t nbytes)
{
vector = vector_free_lists[index];
vector_free_lists[index] = next_vector (vector);
gcstat.total_free_vector_slots -= nbytes / word_size;
return vector;
}
@ -2917,7 +2907,6 @@ allocate_vector_from_block (ptrdiff_t nbytes)
/* This vector is larger than requested. */
vector = vector_free_lists[index];
vector_free_lists[index] = next_vector (vector);
gcstat.total_free_vector_slots -= nbytes / word_size;
/* Excess bytes are used for the smaller vector,
which should be set on an appropriate free list. */
@ -3092,7 +3081,10 @@ sweep_vectors (void)
space was coalesced into the only free vector. */
free_this_block = true;
else
setup_on_free_list (vector, total_bytes);
{
setup_on_free_list (vector, total_bytes);
gcstat.total_free_vector_slots += total_bytes / word_size;
}
}
}
@ -3177,7 +3169,7 @@ allocate_vectorlike (ptrdiff_t len)
if (find_suspicious_object_in_range (p, (char *) p + nbytes))
emacs_abort ();
consing_until_gc -= nbytes;
tally_consing (nbytes);
vector_cells_consed += len;
MALLOC_UNBLOCK_INPUT;
@ -3454,7 +3446,6 @@ Its value is void, and its function definition and property list are nil. */)
new->next = symbol_block;
symbol_block = new;
symbol_block_index = 0;
gcstat.total_free_symbols += SYMBOL_BLOCK_SIZE;
}
XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index]);
symbol_block_index++;
@ -3463,9 +3454,8 @@ Its value is void, and its function definition and property list are nil. */)
MALLOC_UNBLOCK_INPUT;
init_symbol (val, name);
consing_until_gc -= sizeof (struct Lisp_Symbol);
tally_consing (sizeof (struct Lisp_Symbol));
symbols_consed++;
gcstat.total_free_symbols--;
return val;
}
@ -3844,6 +3834,9 @@ set_interval_marked (INTERVAL i)
void
memory_full (size_t nbytes)
{
if (!initialized)
fatal ("memory exhausted");
/* Do not go into hysterics merely because a large request failed. */
bool enough_free_memory = false;
if (SPARE_MEMORY < nbytes)
@ -5500,7 +5493,7 @@ staticpro (Lisp_Object const *varaddress)
static void
allow_garbage_collection (intmax_t consing)
{
consing_until_gc = consing - (INTMAX_MAX - consing_until_gc);
consing_until_gc = consing - (HI_THRESHOLD - consing_until_gc);
garbage_collection_inhibited--;
}
@ -5510,7 +5503,7 @@ inhibit_garbage_collection (void)
ptrdiff_t count = SPECPDL_INDEX ();
record_unwind_protect_intmax (allow_garbage_collection, consing_until_gc);
garbage_collection_inhibited++;
consing_until_gc = INTMAX_MAX;
consing_until_gc = HI_THRESHOLD;
return count;
}
@ -5720,7 +5713,7 @@ visit_buffer_root (struct gc_root_visitor visitor,
There are other GC roots of course, but these roots are dynamic
runtime data structures that pdump doesn't care about and so we can
continue to mark those directly in garbage_collect_1. */
continue to mark those directly in garbage_collect. */
void
visit_static_gc_roots (struct gc_root_visitor visitor)
{
@ -5750,8 +5743,7 @@ mark_object_root_visitor (Lisp_Object const *root_ptr,
}
/* List of weak hash tables we found during marking the Lisp heap.
Will be NULL on entry to garbage_collect_1 and after it
returns. */
NULL on entry to garbage_collect and after it returns. */
static struct Lisp_Hash_Table *weak_hash_tables;
NO_INLINE /* For better stack traces */
@ -5785,11 +5777,13 @@ mark_and_sweep_weak_table_contents (void)
}
}
/* Return the number of bytes to cons between GCs, assuming
gc-cons-threshold is THRESHOLD and gc-cons-percentage is
PERCENTAGE. */
static intmax_t
consing_threshold (intmax_t threshold, Lisp_Object percentage)
/* Return the number of bytes to cons between GCs, given THRESHOLD and
PERCENTAGE. When calculating a threshold based on PERCENTAGE,
assume SINCE_GC bytes have been allocated since the most recent GC.
The returned value is positive and no greater than HI_THRESHOLD. */
static EMACS_INT
consing_threshold (intmax_t threshold, Lisp_Object percentage,
intmax_t since_gc)
{
if (!NILP (Vmemory_full))
return memory_full_cons_threshold;
@ -5799,42 +5793,33 @@ consing_threshold (intmax_t threshold, Lisp_Object percentage)
if (FLOATP (percentage))
{
double tot = (XFLOAT_DATA (percentage)
* total_bytes_of_live_objects ());
* (total_bytes_of_live_objects () + since_gc));
if (threshold < tot)
{
if (tot < INTMAX_MAX)
threshold = tot;
if (tot < HI_THRESHOLD)
return tot;
else
threshold = INTMAX_MAX;
return HI_THRESHOLD;
}
}
return threshold;
return min (threshold, HI_THRESHOLD);
}
}
/* Adjust consing_until_gc, assuming gc-cons-threshold is THRESHOLD and
gc-cons-percentage is PERCENTAGE. */
static Lisp_Object
/* Adjust consing_until_gc and gc_threshold, given THRESHOLD and PERCENTAGE.
Return the updated consing_until_gc. */
static EMACS_INT
bump_consing_until_gc (intmax_t threshold, Lisp_Object percentage)
{
/* If consing_until_gc is negative leave it alone, since this prevents
negative integer overflow and a GC would have been done soon anyway. */
if (0 <= consing_until_gc)
{
threshold = consing_threshold (threshold, percentage);
intmax_t sum;
if (INT_ADD_WRAPV (consing_until_gc, threshold - gc_threshold, &sum))
{
/* Scale the threshold down so that consing_until_gc does
not overflow. */
sum = INTMAX_MAX;
threshold = INTMAX_MAX - consing_until_gc + gc_threshold;
}
consing_until_gc = sum;
gc_threshold = threshold;
}
return Qnil;
/* Guesstimate that half the bytes allocated since the most
recent GC are still in use. */
EMACS_INT since_gc = (gc_threshold - consing_until_gc) >> 1;
EMACS_INT new_gc_threshold = consing_threshold (threshold, percentage,
since_gc);
consing_until_gc += new_gc_threshold - gc_threshold;
gc_threshold = new_gc_threshold;
return consing_until_gc;
}
/* Watch changes to gc-cons-threshold. */
@ -5845,7 +5830,8 @@ watch_gc_cons_threshold (Lisp_Object symbol, Lisp_Object newval,
intmax_t threshold;
if (! (INTEGERP (newval) && integer_to_intmax (newval, &threshold)))
return Qnil;
return bump_consing_until_gc (threshold, Vgc_cons_percentage);
bump_consing_until_gc (threshold, Vgc_cons_percentage);
return Qnil;
}
/* Watch changes to gc-cons-percentage. */
@ -5853,24 +5839,34 @@ static Lisp_Object
watch_gc_cons_percentage (Lisp_Object symbol, Lisp_Object newval,
Lisp_Object operation, Lisp_Object where)
{
return bump_consing_until_gc (gc_cons_threshold, newval);
bump_consing_until_gc (gc_cons_threshold, newval);
return Qnil;
}
/* It may be time to collect garbage. Recalculate consing_until_gc,
since it might depend on current usage, and do the garbage
collection if the recalculation says so. */
void
maybe_garbage_collect (void)
{
if (bump_consing_until_gc (gc_cons_threshold, Vgc_cons_percentage) < 0)
garbage_collect ();
}
/* Subroutine of Fgarbage_collect that does most of the work. */
static bool
garbage_collect_1 (struct gcstat *gcst)
void
garbage_collect (void)
{
struct buffer *nextb;
char stack_top_variable;
bool message_p;
ptrdiff_t count = SPECPDL_INDEX ();
struct timespec start;
byte_ct tot_before = 0;
eassert (weak_hash_tables == NULL);
if (garbage_collection_inhibited)
return false;
return;
/* Record this function, so it appears on the profiler's backtraces. */
record_in_backtrace (QAutomatic_GC, 0, 0);
@ -5880,14 +5876,15 @@ garbage_collect_1 (struct gcstat *gcst)
FOR_EACH_BUFFER (nextb)
compact_buffer (nextb);
if (profiler_memory_running)
tot_before = total_bytes_of_live_objects ();
byte_ct tot_before = (profiler_memory_running
? total_bytes_of_live_objects ()
: (byte_ct) -1);
start = current_timespec ();
/* In case user calls debug_print during GC,
don't let that cause a recursive GC. */
consing_until_gc = INTMAX_MAX;
consing_until_gc = HI_THRESHOLD;
/* Save what's currently displayed in the echo area. Don't do that
if we are GC'ing because we've run out of memory, since
@ -5999,7 +5996,7 @@ garbage_collect_1 (struct gcstat *gcst)
unblock_input ();
consing_until_gc = gc_threshold
= consing_threshold (gc_cons_threshold, Vgc_cons_percentage);
= consing_threshold (gc_cons_threshold, Vgc_cons_percentage, 0);
if (garbage_collection_messages && NILP (Vmemory_full))
{
@ -6011,8 +6008,6 @@ garbage_collect_1 (struct gcstat *gcst)
unbind_to (count, Qnil);
*gcst = gcstat;
/* GC is complete: now we can run our finalizer callbacks. */
run_finalizers (&doomed_finalizers);
@ -6026,29 +6021,21 @@ garbage_collect_1 (struct gcstat *gcst)
/* Accumulate statistics. */
if (FLOATP (Vgc_elapsed))
{
struct timespec since_start = timespec_sub (current_timespec (), start);
Vgc_elapsed = make_float (XFLOAT_DATA (Vgc_elapsed)
+ timespectod (since_start));
static struct timespec gc_elapsed;
gc_elapsed = timespec_add (gc_elapsed,
timespec_sub (current_timespec (), start));
Vgc_elapsed = make_float (timespectod (gc_elapsed));
}
gcs_done++;
/* Collect profiling data. */
if (profiler_memory_running)
if (tot_before != (byte_ct) -1)
{
byte_ct tot_after = total_bytes_of_live_objects ();
byte_ct swept = tot_before <= tot_after ? 0 : tot_before - tot_after;
malloc_probe (min (swept, SIZE_MAX));
if (tot_after < tot_before)
malloc_probe (min (tot_before - tot_after, SIZE_MAX));
}
return true;
}
void
garbage_collect (void)
{
struct gcstat gcst;
garbage_collect_1 (&gcst);
}
DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "",
@ -6068,10 +6055,12 @@ returns nil, because real GC can't be done.
See Info node `(elisp)Garbage Collection'. */)
(void)
{
struct gcstat gcst;
if (!garbage_collect_1 (&gcst))
if (garbage_collection_inhibited)
return Qnil;
garbage_collect ();
struct gcstat gcst = gcstat;
Lisp_Object total[] = {
list4 (Qconses, make_fixnum (sizeof (struct Lisp_Cons)),
make_int (gcst.total_conses),

1
src/callint.c
View file

@ -35,7 +35,6 @@ static Lisp_Object point_marker;
/* String for the prompt text used in Fcall_interactively. */
static Lisp_Object callint_message;
/* ARGSUSED */
DEFUN ("interactive", Finteractive, Sinteractive, 0, UNEVALLED, 0,
doc: /* Specify a way of parsing arguments for interactive use of a function.
For example, write

40
src/callproc.c
View file

@ -108,11 +108,8 @@ static Lisp_Object call_process (ptrdiff_t, Lisp_Object *, int, ptrdiff_t);
Lisp_Object
encode_current_directory (void)
{
Lisp_Object dir;
dir = BVAR (current_buffer, directory);
dir = Funhandled_file_name_directory (dir);
Lisp_Object curdir = BVAR (current_buffer, directory);
Lisp_Object dir = Funhandled_file_name_directory (curdir);
/* If the file name handler says that dir is unreachable, use
a sensible default. */
@ -120,17 +117,10 @@ encode_current_directory (void)
dir = build_string ("~");
dir = expand_and_dir_to_file (dir);
if (NILP (Ffile_accessible_directory_p (dir)))
report_file_error ("Setting current directory",
BVAR (current_buffer, directory));
/* Remove "/:" from DIR and encode it. */
dir = ENCODE_FILE (remove_slash_colon (dir));
if (! file_accessible_directory_p (dir))
report_file_error ("Setting current directory",
BVAR (current_buffer, directory));
report_file_error ("Setting current directory", curdir);
return dir;
}
@ -1570,20 +1560,19 @@ init_callproc (void)
source directory. */
if (data_dir == 0)
{
Lisp_Object tem, tem1, srcdir;
Lisp_Object tem, srcdir;
Lisp_Object lispdir = Fcar (decode_env_path (0, PATH_DUMPLOADSEARCH, 0));
srcdir = Fexpand_file_name (build_string ("../src/"), lispdir);
tem = Fexpand_file_name (build_string ("NEWS"), Vdata_directory);
tem1 = Ffile_exists_p (tem);
if (!NILP (Fequal (srcdir, Vinvocation_directory)) || NILP (tem1))
if (!NILP (Fequal (srcdir, Vinvocation_directory))
|| !file_access_p (SSDATA (tem), F_OK))
{
Lisp_Object newdir;
newdir = Fexpand_file_name (build_string ("../etc/"), lispdir);
tem = Fexpand_file_name (build_string ("NEWS"), newdir);
tem1 = Ffile_exists_p (tem);
if (!NILP (tem1))
if (file_access_p (SSDATA (tem), F_OK))
Vdata_directory = newdir;
}
}
@ -1605,9 +1594,22 @@ init_callproc (void)
Lisp_Object gamedir = Qnil;
if (PATH_GAME)
{
Lisp_Object path_game = build_unibyte_string (PATH_GAME);
const char *cpath_game = PATH_GAME;
#ifdef WINDOWSNT
/* On MS-Windows, PATH_GAME normally starts with a literal
"%emacs_dir%", so it will never work without some tweaking. */
cpath_game = w32_relocate (cpath_game);
#endif
Lisp_Object path_game = build_unibyte_string (cpath_game);
if (file_accessible_directory_p (path_game))
gamedir = path_game;
else if (errno != ENOENT && errno != ENOTDIR
#ifdef DOS_NT
/* DOS/Windows sometimes return EACCES for bad file names */
&& errno != EACCES
#endif
)
dir_warning ("game dir", path_game);
}
Vshared_game_score_directory = gamedir;
}

20
src/charset.c
View file

@ -2292,14 +2292,18 @@ init_charset (void)
{
/* This used to be non-fatal (dir_warning), but it should not
happen, and if it does sooner or later it will cause some
obscure problem (eg bug#6401), so better abort. */
fprintf (stderr, "Error: charsets directory not found:\n\
%s\n\
Emacs will not function correctly without the character map files.\n%s\
Please check your installation!\n",
SDATA (tempdir),
egetenv("EMACSDATA") ? "The EMACSDATA environment \
variable is set, maybe it has the wrong value?\n" : "");
obscure problem (eg bug#6401), so better exit. */
fprintf (stderr,
("Error: %s: %s\n"
"Emacs will not function correctly "
"without the character map files.\n"
"%s"
"Please check your installation!\n"),
SDATA (tempdir), strerror (errno),
(egetenv ("EMACSDATA")
? ("The EMACSDATA environment variable is set. "
"Maybe it has the wrong value?\n")
: ""));
exit (1);
}

1
src/cm.c
View file

@ -30,7 +30,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
int cost; /* sums up costs */
/* ARGSUSED */
int
evalcost (int c)
{

12
src/dbusbind.c
View file

@ -26,6 +26,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "lisp.h"
#include "termhooks.h"
#include "keyboard.h"
#include "pdumper.h"
#include "process.h"
#ifndef DBUS_NUM_MESSAGE_TYPES
@ -1681,6 +1682,12 @@ init_dbusbind (void)
xputenv ("DBUS_FATAL_WARNINGS=0");
}
static void
syms_of_dbusbind_for_pdumper (void)
{
xd_registered_buses = Qnil;
}
void
syms_of_dbusbind (void)
{
@ -1829,13 +1836,10 @@ be called when the D-Bus reply message arrives. */);
#endif
/* Initialize internal objects. */
xd_registered_buses = Qnil;
pdumper_do_now_and_after_load (syms_of_dbusbind_for_pdumper);
staticpro (&xd_registered_buses);
// TODO: reset buses on dump load
Fprovide (intern_c_string ("dbusbind"), Qnil);
}
#endif /* HAVE_DBUS */

151
src/dired.c
View file

@ -79,9 +79,9 @@ dirent_type (struct dirent *dp)
}
static DIR *
open_directory (Lisp_Object dirname, int *fdp)
open_directory (Lisp_Object dirname, Lisp_Object encoded_dirname, int *fdp)
{
char *name = SSDATA (dirname);
char *name = SSDATA (encoded_dirname);
DIR *d;
int fd, opendir_errno;
@ -167,38 +167,31 @@ directory_files_internal (Lisp_Object directory, Lisp_Object full,
Lisp_Object match, Lisp_Object nosort, bool attrs,
Lisp_Object id_format)
{
ptrdiff_t directory_nbytes;
Lisp_Object list, dirfilename, encoded_directory;
bool needsep = 0;
ptrdiff_t count = SPECPDL_INDEX ();
#ifdef WINDOWSNT
Lisp_Object w32_save = Qnil;
#endif
if (!NILP (match))
CHECK_STRING (match);
/* Don't let the compiler optimize away all copies of DIRECTORY,
which would break GC; see Bug#16986. */
Lisp_Object volatile directory_volatile = directory;
/* Because of file name handlers, these functions might call
Ffuncall, and cause a GC. */
list = encoded_directory = dirfilename = Qnil;
dirfilename = Fdirectory_file_name (directory);
Lisp_Object dirfilename = Fdirectory_file_name (directory);
/* Note: ENCODE_FILE and DECODE_FILE can GC because they can run
run_pre_post_conversion_on_str which calls Lisp directly and
indirectly. */
dirfilename = ENCODE_FILE (dirfilename);
encoded_directory = ENCODE_FILE (directory);
Lisp_Object encoded_dirfilename = ENCODE_FILE (dirfilename);
int fd;
DIR *d = open_directory (dirfilename, &fd);
DIR *d = open_directory (dirfilename, encoded_dirfilename, &fd);
/* Unfortunately, we can now invoke expand-file-name and
file-attributes on filenames, both of which can throw, so we must
do a proper unwind-protect. */
ptrdiff_t count = SPECPDL_INDEX ();
record_unwind_protect_ptr (directory_files_internal_unwind, d);
#ifdef WINDOWSNT
Lisp_Object w32_save = Qnil;
if (attrs)
{
/* Do this only once to avoid doing it (in w32.c:stat) for each
@ -210,7 +203,7 @@ directory_files_internal (Lisp_Object directory, Lisp_Object full,
{
/* w32.c:stat will notice these bindings and avoid calling
GetDriveType for each file. */
if (is_slow_fs (SSDATA (dirfilename)))
if (is_slow_fs (SSDATA (encoded_dirfilename)))
Vw32_get_true_file_attributes = Qnil;
else
Vw32_get_true_file_attributes = Qt;
@ -218,88 +211,63 @@ directory_files_internal (Lisp_Object directory, Lisp_Object full,
}
#endif
directory_nbytes = SBYTES (directory);
ptrdiff_t directory_nbytes = SBYTES (directory);
re_match_object = Qt;
/* Decide whether we need to add a directory separator. */
if (directory_nbytes == 0
|| !IS_ANY_SEP (SREF (directory, directory_nbytes - 1)))
needsep = 1;
bool needsep = (directory_nbytes == 0
|| !IS_ANY_SEP (SREF (directory, directory_nbytes - 1)));
/* Windows users want case-insensitive wildcards. */
Lisp_Object case_table =
Lisp_Object case_table = Qnil;
#ifdef WINDOWSNT
BVAR (&buffer_defaults, case_canon_table)
#else
Qnil
case_table = BVAR (&buffer_defaults, case_canon_table);
#endif
;
if (!NILP (match))
CHECK_STRING (match);
/* Loop reading directory entries. */
/* Read directory entries and accumulate them into LIST. */
Lisp_Object list = Qnil;
for (struct dirent *dp; (dp = read_dirent (d, directory)); )
{
ptrdiff_t len = dirent_namelen (dp);
Lisp_Object name = make_unibyte_string (dp->d_name, len);
Lisp_Object finalname = name;
/* Note: DECODE_FILE can GC; it should protect its argument,
though. */
/* This can GC. */
name = DECODE_FILE (name);
len = SBYTES (name);
/* Now that we have unwind_protect in place, we might as well
allow matching to be interrupted. */
maybe_quit ();
bool wanted = (NILP (match) ||
fast_string_match_internal (
match, name, case_table) >= 0);
if (!NILP (match)
&& fast_string_match_internal (match, name, case_table) < 0)
continue;
if (wanted)
Lisp_Object fileattrs UNINIT;
if (attrs)
{
if (!NILP (full))
{
Lisp_Object fullname;
ptrdiff_t nbytes = len + directory_nbytes + needsep;
ptrdiff_t nchars;
fullname = make_uninit_multibyte_string (nbytes, nbytes);
memcpy (SDATA (fullname), SDATA (directory),
directory_nbytes);
if (needsep)
SSET (fullname, directory_nbytes, DIRECTORY_SEP);
memcpy (SDATA (fullname) + directory_nbytes + needsep,
SDATA (name), len);
nchars = multibyte_chars_in_text (SDATA (fullname), nbytes);
/* Some bug somewhere. */
if (nchars > nbytes)
emacs_abort ();
STRING_SET_CHARS (fullname, nchars);
if (nchars == nbytes)
STRING_SET_UNIBYTE (fullname);
finalname = fullname;
}
else
finalname = name;
if (attrs)
{
Lisp_Object fileattrs
= file_attributes (fd, dp->d_name, directory, name, id_format);
list = Fcons (Fcons (finalname, fileattrs), list);
}
else
list = Fcons (finalname, list);
fileattrs = file_attributes (fd, dp->d_name, directory, name,
id_format);
if (NILP (fileattrs))
continue;
}
if (!NILP (full))
{
ptrdiff_t name_nbytes = SBYTES (name);
ptrdiff_t nbytes = directory_nbytes + needsep + name_nbytes;
ptrdiff_t nchars = SCHARS (directory) + needsep + SCHARS (name);
finalname = make_uninit_multibyte_string (nchars, nbytes);
if (nchars == nbytes)
STRING_SET_UNIBYTE (finalname);
memcpy (SDATA (finalname), SDATA (directory), directory_nbytes);
if (needsep)
SSET (finalname, directory_nbytes, DIRECTORY_SEP);
memcpy (SDATA (finalname) + directory_nbytes + needsep,
SDATA (name), name_nbytes);
}
else
finalname = name;
list = Fcons (attrs ? Fcons (finalname, fileattrs) : finalname, list);
}
closedir (d);
@ -329,14 +297,14 @@ If MATCH is non-nil, mention only file names that match the regexp MATCH.
If NOSORT is non-nil, the list is not sorted--its order is unpredictable.
Otherwise, the list returned is sorted with `string-lessp'.
NOSORT is useful if you plan to sort the result yourself. */)
(Lisp_Object directory, Lisp_Object full, Lisp_Object match, Lisp_Object nosort)
(Lisp_Object directory, Lisp_Object full, Lisp_Object match,
Lisp_Object nosort)
{
Lisp_Object handler;
directory = Fexpand_file_name (directory, Qnil);
/* If the file name has special constructs in it,
call the corresponding file name handler. */
handler = Ffind_file_name_handler (directory, Qdirectory_files);
Lisp_Object handler = Ffind_file_name_handler (directory, Qdirectory_files);
if (!NILP (handler))
return call5 (handler, Qdirectory_files, directory,
full, match, nosort);
@ -364,14 +332,15 @@ ID-FORMAT specifies the preferred format of attributes uid and gid, see
`file-attributes' for further documentation.
On MS-Windows, performance depends on `w32-get-true-file-attributes',
which see. */)
(Lisp_Object directory, Lisp_Object full, Lisp_Object match, Lisp_Object nosort, Lisp_Object id_format)
(Lisp_Object directory, Lisp_Object full, Lisp_Object match,
Lisp_Object nosort, Lisp_Object id_format)
{
Lisp_Object handler;
directory = Fexpand_file_name (directory, Qnil);
/* If the file name has special constructs in it,
call the corresponding file name handler. */
handler = Ffind_file_name_handler (directory, Qdirectory_files_and_attributes);
Lisp_Object handler
= Ffind_file_name_handler (directory, Qdirectory_files_and_attributes);
if (!NILP (handler))
return call6 (handler, Qdirectory_files_and_attributes,
directory, full, match, nosort, id_format);
@ -508,7 +477,7 @@ file_name_completion (Lisp_Object file, Lisp_Object dirname, bool all_flag,
}
}
int fd;
DIR *d = open_directory (encoded_dir, &fd);
DIR *d = open_directory (dirname, encoded_dir, &fd);
record_unwind_protect_ptr (directory_files_internal_unwind, d);
/* Loop reading directory entries. */
@ -850,7 +819,7 @@ stat_gname (struct stat *st)
DEFUN ("file-attributes", Ffile_attributes, Sfile_attributes, 1, 2, 0,
doc: /* Return a list of attributes of file FILENAME.
Value is nil if specified file cannot be opened.
Value is nil if specified file does not exist.
ID-FORMAT specifies the preferred format of attributes uid and gid (see
below) - valid values are `string' and `integer'. The latter is the
@ -970,15 +939,14 @@ file_attributes (int fd, char const *name,
information to be accurate. */
w32_stat_get_owner_group = 1;
#endif
if (fstatat (fd, name, &s, AT_SYMLINK_NOFOLLOW) == 0)
err = 0;
err = fstatat (fd, name, &s, AT_SYMLINK_NOFOLLOW) == 0 ? 0 : errno;
#ifdef WINDOWSNT
w32_stat_get_owner_group = 0;
#endif
}
if (err != 0)
return unbind_to (count, Qnil);
return unbind_to (count, file_attribute_errno (filename, err));
Lisp_Object file_type;
if (S_ISLNK (s.st_mode))
@ -987,7 +955,7 @@ file_attributes (int fd, char const *name,
symlink is replaced between the call to fstatat and the call
to emacs_readlinkat. Detect this race unless the replacement
is also a symlink. */
file_type = emacs_readlinkat (fd, name);
file_type = check_emacs_readlinkat (fd, filename, name);
if (NILP (file_type))
return unbind_to (count, Qnil);
}
@ -1031,7 +999,8 @@ file_attributes (int fd, char const *name,
INT_TO_INTEGER (s.st_dev));
}
DEFUN ("file-attributes-lessp", Ffile_attributes_lessp, Sfile_attributes_lessp, 2, 2, 0,
DEFUN ("file-attributes-lessp", Ffile_attributes_lessp,
Sfile_attributes_lessp, 2, 2, 0,
doc: /* Return t if first arg file attributes list is less than second.
Comparison is in lexicographic order and case is significant. */)
(Lisp_Object f1, Lisp_Object f2)

2
src/doc.c
View file

@ -136,7 +136,7 @@ get_doc_string (Lisp_Object filepos, bool unibyte, bool definition)
}
if (fd < 0)
{
if (errno == EMFILE || errno == ENFILE)
if (errno != ENOENT && errno != ENOTDIR)
report_file_error ("Read error on documentation file", file);
SAFE_FREE ();

183
src/emacs.c
View file

@ -662,7 +662,7 @@ argmatch (char **argv, int argc, const char *sstr, const char *lstr,
#ifdef HAVE_PDUMPER
static const char *
dump_error_to_string (enum pdumper_load_result result)
dump_error_to_string (int result)
{
switch (result)
{
@ -681,37 +681,29 @@ dump_error_to_string (enum pdumper_load_result result)
case PDUMPER_LOAD_VERSION_MISMATCH:
return "not built for this Emacs executable";
default:
return "generic error";
return (result <= PDUMPER_LOAD_ERROR
? "generic error"
: strerror (result - PDUMPER_LOAD_ERROR));
}
}
/* Find a path (absolute or relative) to the Emacs executable.
Called early in initialization by portable dumper loading code, so we
can't use lisp and associated machinery. On success, *EXENAME is
set to a heap-allocated string giving a path to the Emacs
executable or to NULL if we can't determine the path immediately.
*/
static enum pdumper_load_result
load_pdump_find_executable (const char* argv0, char **exename)
/* Find a name (absolute or relative) of the Emacs executable whose
name (as passed into this program) is ARGV0. Called early in
initialization by portable dumper loading code, so avoid Lisp and
associated machinery. Return a heap-allocated string giving a name
of the Emacs executable, or an empty heap-allocated string or NULL
if not found. Store into *CANDIDATE_SIZE a lower bound on the size
of any heap allocation. */
static char *
load_pdump_find_executable (char const *argv0, ptrdiff_t *candidate_size)
{
enum pdumper_load_result result;
*candidate_size = 0;
/* Use xstrdup etc. to allocate storage, so as to call our private
implementation of malloc, since the caller calls our free. */
#ifdef WINDOWSNT
result = PDUMPER_LOAD_ERROR;
*exename = NULL;
char *prog_fname = w32_my_exename ();
if (prog_fname)
{
result = PDUMPER_LOAD_OOM;
/* Use xstrdup, so as to call our private implementation of
malloc, since the caller calls our free. */
char *ret = xstrdup (prog_fname);
if (ret)
{
*exename = ret;
result = PDUMPER_LOAD_SUCCESS;
}
}
return result;
return prog_fname ? xstrdup (prog_fname) : NULL;
#else /* !WINDOWSNT */
char *candidate = NULL;
@ -719,33 +711,23 @@ load_pdump_find_executable (const char* argv0, char **exename)
path already, so just copy it. */
eassert (argv0);
if (strchr (argv0, DIRECTORY_SEP))
{
result = PDUMPER_LOAD_OOM;
char *ret = strdup (argv0);
if (!ret)
goto out;
result = PDUMPER_LOAD_SUCCESS;
*exename = ret;
goto out;
}
size_t argv0_length = strlen (argv0);
return xstrdup (argv0);
ptrdiff_t argv0_length = strlen (argv0);
const char *path = getenv ("PATH");
if (!path)
{
/* Default PATH is implementation-defined, so we don't know how
to conduct the search. */
result = PDUMPER_LOAD_SUCCESS;
*exename = NULL;
goto out;
return NULL;
}
/* Actually try each concatenation of a path element and the
executable basename. */
const char path_sep[] = { SEPCHAR, '\0' };
do
{
size_t path_part_length = strcspn (path, path_sep);
static char const path_sep[] = { SEPCHAR, '\0' };
ptrdiff_t path_part_length = strcspn (path, path_sep);
const char *path_part = path;
path += path_part_length;
if (path_part_length == 0)
@ -753,46 +735,34 @@ load_pdump_find_executable (const char* argv0, char **exename)
path_part = ".";
path_part_length = 1;
}
size_t candidate_length = path_part_length + 1 + argv0_length;
{
char *new_candidate = realloc (candidate, candidate_length + 1);
if (!new_candidate)
{
result = PDUMPER_LOAD_OOM;
goto out;
}
candidate = new_candidate;
}
ptrdiff_t needed = path_part_length + 1 + argv0_length + 1;
if (*candidate_size <= needed)
{
xfree (candidate);
candidate = xpalloc (NULL, candidate_size,
needed - *candidate_size + 1, -1, 1);
}
memcpy (candidate + 0, path_part, path_part_length);
candidate[path_part_length] = DIRECTORY_SEP;
memcpy (candidate + path_part_length + 1, argv0, argv0_length + 1);
struct stat st;
if (!access (candidate, X_OK) &&
!stat (candidate, &st) &&
S_ISREG (st.st_mode))
{
*exename = candidate;
candidate = NULL;
break;
}
} while ((path++)[0] != '\0');
if (file_access_p (candidate, X_OK)
&& stat (candidate, &st) == 0 && S_ISREG (st.st_mode))
return candidate;
*candidate = '\0';
}
while (*path++ != '\0');
result = PDUMPER_LOAD_SUCCESS;
out:
free (candidate);
return result;
return candidate;
#endif /* !WINDOWSNT */
}
static enum pdumper_load_result
static void
load_pdump (int argc, char **argv)
{
const char *const suffix = ".pdmp";
enum pdumper_load_result result;
char *exename = NULL;
char *real_exename = NULL;
const char* strip_suffix =
int result;
const char *strip_suffix =
#if defined DOS_NT || defined CYGWIN
".exe"
#else
@ -821,7 +791,6 @@ load_pdump (int argc, char **argv)
skip_args++;
}
result = PDUMPER_NOT_LOADED;
if (dump_file)
{
result = pdumper_load (dump_file);
@ -829,8 +798,7 @@ load_pdump (int argc, char **argv)
if (result != PDUMPER_LOAD_SUCCESS)
fatal ("could not load dump file \"%s\": %s",
dump_file, dump_error_to_string (result));
else
goto out;
return;
}
/* Look for a dump file in the same directory as the executable; it
@ -839,44 +807,41 @@ load_pdump (int argc, char **argv)
so we can't use decode_env_path. We're working in whatever
encoding the system natively uses for filesystem access, so
there's no need for character set conversion. */
result = load_pdump_find_executable (argv[0], &exename);
if (result != PDUMPER_LOAD_SUCCESS)
goto out;
ptrdiff_t bufsize;
dump_file = load_pdump_find_executable (argv[0], &bufsize);
/* If we couldn't find our executable, go straight to looking for
the dump in the hardcoded location. */
if (exename)
if (dump_file && *dump_file)
{
#ifdef WINDOWSNT
/* w32_my_exename resolves symlinks internally, so no need to
call realpath. */
real_exename = exename;
exename = NULL;
#else
real_exename = realpath (exename, NULL);
char *real_exename = realpath (dump_file, NULL);
if (!real_exename)
fatal ("could not resolve realpath of \"%s\": %s",
exename, strerror (errno));
dump_file, strerror (errno));
xfree (dump_file);
dump_file = real_exename;
#endif
ptrdiff_t exenamelen = strlen (dump_file);
#ifndef WINDOWSNT
bufsize = exenamelen + 1;
#endif
size_t real_exename_length = strlen (real_exename);
if (strip_suffix)
{
size_t strip_suffix_length = strlen (strip_suffix);
if (real_exename_length >= strip_suffix_length)
{
size_t prefix_length =
real_exename_length - strip_suffix_length;
if (!memcmp (&real_exename[prefix_length],
strip_suffix,
strip_suffix_length))
real_exename_length = prefix_length;
}
ptrdiff_t strip_suffix_length = strlen (strip_suffix);
ptrdiff_t prefix_length = exenamelen - strip_suffix_length;
if (0 <= prefix_length
&& !memcmp (&dump_file[prefix_length], strip_suffix,
strip_suffix_length))
exenamelen = prefix_length;
}
dump_file = alloca (real_exename_length + strlen (suffix) + 1);
memcpy (dump_file, real_exename, real_exename_length);
memcpy (dump_file + real_exename_length,
suffix,
strlen (suffix) + 1);
ptrdiff_t needed = exenamelen + strlen (suffix) + 1;
if (bufsize < needed)
dump_file = xpalloc (dump_file, &bufsize, needed - bufsize, -1, 1);
strcpy (dump_file + exenamelen, suffix);
result = pdumper_load (dump_file);
if (result == PDUMPER_LOAD_SUCCESS)
goto out;
@ -896,16 +861,19 @@ load_pdump (int argc, char **argv)
"emacs.pdmp" so that the Emacs binary still works if the user
copies and renames it. */
const char *argv0_base = "emacs";
dump_file = alloca (strlen (path_exec)
ptrdiff_t needed = (strlen (path_exec)
+ 1
+ strlen (argv0_base)
+ strlen (suffix)
+ 1);
if (bufsize < needed)
{
xfree (dump_file);
dump_file = xpalloc (NULL, &bufsize, needed - bufsize, -1, 1);
}
sprintf (dump_file, "%s%c%s%s",
path_exec, DIRECTORY_SEP, argv0_base, suffix);
result = pdumper_load (dump_file);
if (result == PDUMPER_LOAD_SUCCESS)
goto out;
if (result == PDUMPER_LOAD_FILE_NOT_FOUND)
{
@ -920,13 +888,18 @@ load_pdump (int argc, char **argv)
last_sep = p;
}
argv0_base = last_sep ? last_sep + 1 : argv[0];
dump_file = alloca (strlen (path_exec)
ptrdiff_t needed = (strlen (path_exec)
+ 1
+ strlen (argv0_base)
+ strlen (suffix)
+ 1);
if (bufsize < needed)
{
xfree (dump_file);
dump_file = xmalloc (needed);
}
#ifdef DOS_NT
size_t argv0_len = strlen (argv0_base);
ptrdiff_t argv0_len = strlen (argv0_base);
if (argv0_len >= 4
&& c_strcasecmp (argv0_base + argv0_len - 4, ".exe") == 0)
sprintf (dump_file, "%s%c%.*s%s", path_exec, DIRECTORY_SEP,
@ -943,17 +916,13 @@ load_pdump (int argc, char **argv)
if (result != PDUMPER_LOAD_FILE_NOT_FOUND)
fatal ("could not load dump file \"%s\": %s",
dump_file, dump_error_to_string (result));
dump_file = NULL;
}
out:
free (exename);
free (real_exename);
return result;
xfree (dump_file);
}
#endif /* HAVE_PDUMPER */
/* ARGSUSED */
int
main (int argc, char **argv)
{

9
src/eval.c
View file

@ -1890,7 +1890,6 @@ verror (const char *m, va_list ap)
/* Dump an error message; called like printf. */
/* VARARGS 1 */
void
error (const char *m, ...)
{
@ -2649,7 +2648,6 @@ call0 (Lisp_Object fn)
}
/* Call function fn with 1 argument arg1. */
/* ARGSUSED */
Lisp_Object
call1 (Lisp_Object fn, Lisp_Object arg1)
{
@ -2657,7 +2655,6 @@ call1 (Lisp_Object fn, Lisp_Object arg1)
}
/* Call function fn with 2 arguments arg1, arg2. */
/* ARGSUSED */
Lisp_Object
call2 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2)
{
@ -2665,7 +2662,6 @@ call2 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2)
}
/* Call function fn with 3 arguments arg1, arg2, arg3. */
/* ARGSUSED */
Lisp_Object
call3 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3)
{
@ -2673,7 +2669,6 @@ call3 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3)
}
/* Call function fn with 4 arguments arg1, arg2, arg3, arg4. */
/* ARGSUSED */
Lisp_Object
call4 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
Lisp_Object arg4)
@ -2682,7 +2677,6 @@ call4 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
}
/* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5. */
/* ARGSUSED */
Lisp_Object
call5 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
Lisp_Object arg4, Lisp_Object arg5)
@ -2691,7 +2685,6 @@ call5 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
}
/* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6. */
/* ARGSUSED */
Lisp_Object
call6 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
Lisp_Object arg4, Lisp_Object arg5, Lisp_Object arg6)
@ -2700,7 +2693,6 @@ call6 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
}
/* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7. */
/* ARGSUSED */
Lisp_Object
call7 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
Lisp_Object arg4, Lisp_Object arg5, Lisp_Object arg6, Lisp_Object arg7)
@ -2710,7 +2702,6 @@ call7 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
/* Call function fn with 8 arguments arg1, arg2, arg3, arg4, arg5,
arg6, arg7, arg8. */
/* ARGSUSED */
Lisp_Object
call8 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
Lisp_Object arg4, Lisp_Object arg5, Lisp_Object arg6, Lisp_Object arg7,

480
src/fileio.c
View file

@ -134,60 +134,45 @@ static dev_t timestamp_file_system;
is added here. */
static Lisp_Object Vwrite_region_annotation_buffers;
static Lisp_Object file_name_directory (Lisp_Object);
static bool a_write (int, Lisp_Object, ptrdiff_t, ptrdiff_t,
Lisp_Object *, struct coding_system *);
static bool e_write (int, Lisp_Object, ptrdiff_t, ptrdiff_t,
struct coding_system *);
/* Return true if FILENAME exists, otherwise return false and set errno. */
/* Test whether FILE is accessible for AMODE.
Return true if successful, false (setting errno) otherwise. */
static bool
check_existing (const char *filename)
{
return faccessat (AT_FDCWD, filename, F_OK, AT_EACCESS) == 0;
}
/* Return true if file FILENAME exists and can be executed. */
static bool
check_executable (char *filename)
{
return faccessat (AT_FDCWD, filename, X_OK, AT_EACCESS) == 0;
}
/* Return true if file FILENAME exists and can be accessed
according to AMODE, which should include W_OK.
On failure, return false and set errno. */
static bool
check_writable (const char *filename, int amode)
bool
file_access_p (char const *file, int amode)
{
#ifdef MSDOS
/* FIXME: an faccessat implementation should be added to the
DOS/Windows ports and this #ifdef branch should be removed. */
struct stat st;
if (stat (filename, &st) < 0)
return 0;
errno = EPERM;
return (st.st_mode & S_IWRITE || S_ISDIR (st.st_mode));
#else /* not MSDOS */
bool res = faccessat (AT_FDCWD, filename, amode, AT_EACCESS) == 0;
#ifdef CYGWIN
/* faccessat may have returned failure because Cygwin couldn't
determine the file's UID or GID; if so, we return success. */
if (!res)
if (amode & W_OK)
{
int faccessat_errno = errno;
/* FIXME: The MS-DOS faccessat implementation should handle this. */
struct stat st;
if (stat (filename, &st) < 0)
return 0;
res = (st.st_uid == -1 || st.st_gid == -1);
errno = faccessat_errno;
if (stat (file, &st) != 0)
return false;
errno = EPERM;
return st.st_mode & S_IWRITE || S_ISDIR (st.st_mode);
}
#endif /* CYGWIN */
return res;
#endif /* not MSDOS */
#endif
if (faccessat (AT_FDCWD, file, amode, AT_EACCESS) == 0)
return true;
#ifdef CYGWIN
/* Return success if faccessat failed because Cygwin couldn't
determine the file's UID or GID. */
int err = errno;
struct stat st;
if (stat (file, &st) == 0 && (st.st_uid == -1 || st.st_gid == -1))
return true;
errno = err;
#endif
return false;
}
/* Signal a file-access failure. STRING describes the failure,
@ -250,6 +235,44 @@ report_file_notify_error (const char *string, Lisp_Object name)
}
#endif
/* ACTION failed for FILE with errno ERR. Signal an error if ERR
means the file's metadata could not be retrieved even though it may
exist, otherwise return nil. */
static Lisp_Object
file_metadata_errno (char const *action, Lisp_Object file, int err)
{
if (err == ENOENT || err == ENOTDIR || err == 0)
return Qnil;
report_file_errno (action, file, err);
}
Lisp_Object
file_attribute_errno (Lisp_Object file, int err)
{
return file_metadata_errno ("Getting attributes", file, err);
}
/* In theory, EACCES errors for predicates like file-readable-p should
be checked further because they may be problems with an ancestor
directory instead of with the file itself, which means that we
don't have reliable info about the requested file. In practice,
though, such errors are common enough that signaling them can be
annoying even if the errors are real (e.g., Bug#37445). So return
nil for EACCES unless compiling with -DPICKY_EACCES, which is off
by default. */
#ifndef PICKY_EACCES
enum { PICKY_EACCES = false };
#endif
Lisp_Object
file_test_errno (Lisp_Object file, int err)
{
if (!PICKY_EACCES && err == EACCES)
return Qnil;
return file_metadata_errno ("Testing file", file, err);
}
void
close_file_unwind (int fd)
{
@ -356,6 +379,15 @@ Given a Unix syntax file name, returns a string ending in slash. */)
return STRINGP (handled_name) ? handled_name : Qnil;
}
return file_name_directory (filename);
}
/* Return the directory component of FILENAME, or nil if FILENAME does
not contain a directory component. */
static Lisp_Object
file_name_directory (Lisp_Object filename)
{
char *beg = SSDATA (filename);
char const *p = beg + SBYTES (filename);
@ -2369,41 +2401,48 @@ internal_delete_file (Lisp_Object filename)
return NILP (tem);
}
/* Filesystems are case-sensitive on all supported systems except
MS-Windows, MS-DOS, Cygwin, and Mac OS X. They are always
case-insensitive on the first two, but they may or may not be
case-insensitive on Cygwin and OS X. The following function
attempts to provide a runtime test on those two systems. If the
test is not conclusive, we assume case-insensitivity on Cygwin and
case-sensitivity on Mac OS X.
/* Return -1 if FILE is a case-insensitive file name, 0 if not,
and a positive errno value if the result cannot be determined. */
FIXME: Mounted filesystems on Posix hosts, like Samba shares or
NFS-mounted Windows volumes, might be case-insensitive. Can we
detect this? */
static bool
file_name_case_insensitive_p (const char *filename)
static int
file_name_case_insensitive_err (Lisp_Object file)
{
/* Use pathconf with _PC_CASE_INSENSITIVE or _PC_CASE_SENSITIVE if
those flags are available. As of this writing (2017-05-20),
/* Filesystems are case-sensitive on all supported systems except
MS-Windows, MS-DOS, Cygwin, and macOS. They are always
case-insensitive on the first two, but they may or may not be
case-insensitive on Cygwin and macOS so do a runtime test on
those two systems. If the test is not conclusive, assume
case-insensitivity on Cygwin and case-sensitivity on macOS.
FIXME: Mounted filesystems on Posix hosts, like Samba shares or
NFS-mounted Windows volumes, might be case-insensitive. Can we
detect this?
Use pathconf with _PC_CASE_INSENSITIVE or _PC_CASE_SENSITIVE if
those flags are available. As of this writing (2019-09-15),
Cygwin is the only platform known to support the former (starting
with Cygwin-2.6.1), and macOS is the only platform known to
support the latter. */
#ifdef _PC_CASE_INSENSITIVE
int res = pathconf (filename, _PC_CASE_INSENSITIVE);
#if defined _PC_CASE_INSENSITIVE || defined _PC_CASE_SENSITIVE
char *filename = SSDATA (ENCODE_FILE (file));
# ifdef _PC_CASE_INSENSITIVE
long int res = pathconf (filename, _PC_CASE_INSENSITIVE);
if (res >= 0)
return res > 0;
#elif defined _PC_CASE_SENSITIVE
int res = pathconf (filename, _PC_CASE_SENSITIVE);
return - (res > 0);
# else
long int res = pathconf (filename, _PC_CASE_SENSITIVE);
if (res >= 0)
return res == 0;
return - (res == 0);
# endif
if (errno != EINVAL)
return errno;
#endif
#if defined CYGWIN || defined DOS_NT
return true;
return -1;
#else
return false;
return 0;
#endif
}
@ -2426,21 +2465,22 @@ The arg must be a string. */)
/* If the file doesn't exist, move up the filesystem tree until we
reach an existing directory or the root. */
if (NILP (Ffile_exists_p (filename)))
while (true)
{
filename = Ffile_name_directory (filename);
while (NILP (Ffile_exists_p (filename)))
int err = file_name_case_insensitive_err (filename);
switch (err)
{
Lisp_Object newname = expand_and_dir_to_file (filename);
/* Avoid infinite loop if the root is reported as non-existing
(impossible?). */
if (!NILP (Fstring_equal (newname, filename)))
break;
filename = newname;
case -1: return Qt;
default: return file_test_errno (filename, err);
case ENOENT: case ENOTDIR: break;
}
Lisp_Object parent = file_name_directory (filename);
/* Avoid infinite loop if the root is reported as non-existing
(impossible?). */
if (!NILP (Fstring_equal (parent, filename)))
return Qnil;
filename = parent;
}
filename = ENCODE_FILE (filename);
return file_name_case_insensitive_p (SSDATA (filename)) ? Qt : Qnil;
}
DEFUN ("rename-file", Frename_file, Srename_file, 2, 3,
@ -2546,7 +2586,7 @@ This is what happens in interactive use with M-x. */)
{
Lisp_Object symlink_target
= (S_ISLNK (file_st.st_mode)
? emacs_readlinkat (AT_FDCWD, SSDATA (encoded_file))
? check_emacs_readlinkat (AT_FDCWD, file, SSDATA (encoded_file))
: Qnil);
if (!NILP (symlink_target))
Fmake_symbolic_link (symlink_target, newname, ok_if_already_exists);
@ -2694,6 +2734,40 @@ file_name_absolute_p (char const *filename)
|| user_homedir (&filename[1]))));
}
/* Return t if FILE exists and is accessible via OPERATION and AMODE,
nil (setting errno) if not. Signal an error if the result cannot
be determined. */
static Lisp_Object
check_file_access (Lisp_Object file, Lisp_Object operation, int amode)
{
file = Fexpand_file_name (file, Qnil);
Lisp_Object handler = Ffind_file_name_handler (file, operation);
if (!NILP (handler))
{
Lisp_Object ok = call2 (handler, operation, file);
/* This errno value is bogus. Any caller that depends on errno
should be rethought anyway, to avoid a race between testing a
handled file's accessibility and using the file. */
errno = 0;
return ok;
}
char *encoded_file = SSDATA (ENCODE_FILE (file));
bool ok = file_access_p (encoded_file, amode);
if (ok)
return Qt;
int err = errno;
if (err == EROFS || err == ETXTBSY
|| (PICKY_EACCES && err == EACCES && amode != F_OK
&& file_access_p (encoded_file, F_OK)))
{
errno = err;
return Qnil;
}
return file_test_errno (file, err);
}
DEFUN ("file-exists-p", Ffile_exists_p, Sfile_exists_p, 1, 1, 0,
doc: /* Return t if file FILENAME exists (whether or not you can read it).
See also `file-readable-p' and `file-attributes'.
@ -2701,25 +2775,7 @@ This returns nil for a symlink to a nonexistent file.
Use `file-symlink-p' to test for such links. */)
(Lisp_Object filename)
{
Lisp_Object absname;
Lisp_Object handler;
CHECK_STRING (filename);
absname = Fexpand_file_name (filename, Qnil);
/* If the file name has special constructs in it,
call the corresponding file name handler. */
handler = Ffind_file_name_handler (absname, Qfile_exists_p);
if (!NILP (handler))
{
Lisp_Object result = call2 (handler, Qfile_exists_p, absname);
errno = 0;
return result;
}
absname = ENCODE_FILE (absname);
return check_existing (SSDATA (absname)) ? Qt : Qnil;
return check_file_access (filename, Qfile_exists_p, F_OK);
}
DEFUN ("file-executable-p", Ffile_executable_p, Sfile_executable_p, 1, 1, 0,
@ -2729,21 +2785,7 @@ For a directory, this means you can access files in that directory.
purpose, though.) */)
(Lisp_Object filename)
{
Lisp_Object absname;
Lisp_Object handler;
CHECK_STRING (filename);
absname = Fexpand_file_name (filename, Qnil);
/* If the file name has special constructs in it,
call the corresponding file name handler. */
handler = Ffind_file_name_handler (absname, Qfile_executable_p);
if (!NILP (handler))
return call2 (handler, Qfile_executable_p, absname);
absname = ENCODE_FILE (absname);
return (check_executable (SSDATA (absname)) ? Qt : Qnil);
return check_file_access (filename, Qfile_executable_p, X_OK);
}
DEFUN ("file-readable-p", Ffile_readable_p, Sfile_readable_p, 1, 1, 0,
@ -2751,21 +2793,7 @@ DEFUN ("file-readable-p", Ffile_readable_p, Sfile_readable_p, 1, 1, 0,
See also `file-exists-p' and `file-attributes'. */)
(Lisp_Object filename)
{
Lisp_Object absname;
Lisp_Object handler;
CHECK_STRING (filename);
absname = Fexpand_file_name (filename, Qnil);
/* If the file name has special constructs in it,
call the corresponding file name handler. */
handler = Ffind_file_name_handler (absname, Qfile_readable_p);
if (!NILP (handler))
return call2 (handler, Qfile_readable_p, absname);
absname = ENCODE_FILE (absname);
return (faccessat (AT_FDCWD, SSDATA (absname), R_OK, AT_EACCESS) == 0
? Qt : Qnil);
return check_file_access (filename, Qfile_readable_p, R_OK);
}
DEFUN ("file-writable-p", Ffile_writable_p, Sfile_writable_p, 1, 1, 0,
@ -2775,7 +2803,6 @@ DEFUN ("file-writable-p", Ffile_writable_p, Sfile_writable_p, 1, 1, 0,
Lisp_Object absname, dir, encoded;
Lisp_Object handler;
CHECK_STRING (filename);
absname = Fexpand_file_name (filename, Qnil);
/* If the file name has special constructs in it,
@ -2785,25 +2812,34 @@ DEFUN ("file-writable-p", Ffile_writable_p, Sfile_writable_p, 1, 1, 0,
return call2 (handler, Qfile_writable_p, absname);
encoded = ENCODE_FILE (absname);
if (check_writable (SSDATA (encoded), W_OK))
if (file_access_p (SSDATA (encoded), W_OK))
return Qt;
if (errno != ENOENT)
return Qnil;
dir = Ffile_name_directory (absname);
dir = file_name_directory (absname);
eassert (!NILP (dir));
#ifdef MSDOS
dir = Fdirectory_file_name (dir);
#endif /* MSDOS */
dir = ENCODE_FILE (dir);
encoded = ENCODE_FILE (dir);
#ifdef WINDOWSNT
/* The read-only attribute of the parent directory doesn't affect
whether a file or directory can be created within it. Some day we
should check ACLs though, which do affect this. */
return file_directory_p (dir) ? Qt : Qnil;
return file_directory_p (encoded) ? Qt : Qnil;
#else
return check_writable (SSDATA (dir), W_OK | X_OK) ? Qt : Qnil;
if (file_access_p (SSDATA (encoded), W_OK | X_OK))
return Qt;
int err = errno;
if (err == EROFS
|| (err == EACCES && file_access_p (SSDATA (encoded), F_OK)))
{
errno = err;
return Qnil;
}
return file_test_errno (absname, err);
#endif
}
@ -2835,8 +2871,8 @@ If there is no error, returns nil. */)
}
/* Relative to directory FD, return the symbolic link value of FILENAME.
On failure, return nil. */
Lisp_Object
On failure, return nil (setting errno). */
static Lisp_Object
emacs_readlinkat (int fd, char const *filename)
{
static struct allocator const emacs_norealloc_allocator =
@ -2855,6 +2891,27 @@ emacs_readlinkat (int fd, char const *filename)
return val;
}
/* Relative to directory FD, return the symbolic link value of FILE.
If FILE is not a symbolic link, return nil (setting errno).
Signal an error if the result cannot be determined. */
Lisp_Object
check_emacs_readlinkat (int fd, Lisp_Object file, char const *encoded_file)
{
Lisp_Object val = emacs_readlinkat (fd, encoded_file);
if (NILP (val))
{
if (errno == EINVAL)
return val;
#ifdef CYGWIN
/* Work around Cygwin bugs. */
if (errno == EIO || errno == EACCES)
return val;
#endif
return file_metadata_errno ("Reading symbolic link", file, errno);
}
return val;
}
DEFUN ("file-symlink-p", Ffile_symlink_p, Sfile_symlink_p, 1, 1, 0,
doc: /* Return non-nil if file FILENAME is the name of a symbolic link.
The value is the link target, as a string.
@ -2874,9 +2931,8 @@ This function does not check whether the link target exists. */)
if (!NILP (handler))
return call2 (handler, Qfile_symlink_p, filename);
filename = ENCODE_FILE (filename);
return emacs_readlinkat (AT_FDCWD, SSDATA (filename));
return check_emacs_readlinkat (AT_FDCWD, filename,
SSDATA (ENCODE_FILE (filename)));
}
DEFUN ("file-directory-p", Ffile_directory_p, Sfile_directory_p, 1, 1, 0,
@ -2893,9 +2949,9 @@ See `file-symlink-p' to distinguish symlinks. */)
if (!NILP (handler))
return call2 (handler, Qfile_directory_p, absname);
absname = ENCODE_FILE (absname);
return file_directory_p (absname) ? Qt : Qnil;
if (file_directory_p (absname))
return Qt;
return file_test_errno (absname, errno);
}
/* Return true if FILE is a directory or a symlink to a directory.
@ -2905,7 +2961,10 @@ file_directory_p (Lisp_Object file)
{
#ifdef DOS_NT
/* This is cheaper than 'stat'. */
return faccessat (AT_FDCWD, SSDATA (file), D_OK, AT_EACCESS) == 0;
bool retval = faccessat (AT_FDCWD, SSDATA (file), D_OK, AT_EACCESS) == 0;
if (!retval && errno == EACCES)
errno = ENOTDIR; /* like the non-DOS_NT branch below does */
return retval;
#else
# ifdef O_PATH
/* Use O_PATH if available, as it avoids races and EOVERFLOW issues. */
@ -2920,7 +2979,7 @@ file_directory_p (Lisp_Object file)
/* O_PATH is defined but evidently this Linux kernel predates 2.6.39.
Fall back on generic POSIX code. */
# endif
/* Use file_accessible_directory, as it avoids stat EOVERFLOW
/* Use file_accessible_directory_p, as it avoids stat EOVERFLOW
problems and could be cheaper. However, if it fails because FILE
is inaccessible, fall back on stat; if the latter fails with
EOVERFLOW then FILE must have been a directory unless a race
@ -2976,8 +3035,13 @@ really is a readable and searchable directory. */)
return r;
}
absname = ENCODE_FILE (absname);
return file_accessible_directory_p (absname) ? Qt : Qnil;
Lisp_Object encoded_absname = ENCODE_FILE (absname);
if (file_accessible_directory_p (encoded_absname))
return Qt;
int err = errno;
if (err == EACCES && file_access_p (SSDATA (encoded_absname), F_OK))
return Qnil;
return file_test_errno (absname, err);
}
/* If FILE is a searchable directory or a symlink to a
@ -3029,7 +3093,7 @@ file_accessible_directory_p (Lisp_Object file)
dir = buf;
}
ok = check_existing (dir);
ok = file_access_p (dir, F_OK);
saved_errno = errno;
SAFE_FREE ();
errno = saved_errno;
@ -3053,27 +3117,21 @@ See `file-symlink-p' to distinguish symlinks. */)
if (!NILP (handler))
return call2 (handler, Qfile_regular_p, absname);
absname = ENCODE_FILE (absname);
#ifdef WINDOWSNT
/* Tell stat to use expensive method to get accurate info. */
Lisp_Object true_attributes = Vw32_get_true_file_attributes;
Vw32_get_true_file_attributes = Qt;
#endif
int stat_result = stat (SSDATA (absname), &st);
#ifdef WINDOWSNT
{
int result;
Lisp_Object tem = Vw32_get_true_file_attributes;
/* Tell stat to use expensive method to get accurate info. */
Vw32_get_true_file_attributes = Qt;
result = stat (SSDATA (absname), &st);
Vw32_get_true_file_attributes = tem;
if (result < 0)
return Qnil;
return S_ISREG (st.st_mode) ? Qt : Qnil;
}
#else
if (stat (SSDATA (absname), &st) < 0)
return Qnil;
return S_ISREG (st.st_mode) ? Qt : Qnil;
Vw32_get_true_file_attributes = true_attributes;
#endif
if (stat_result == 0)
return S_ISREG (st.st_mode) ? Qt : Qnil;
return file_test_errno (absname, errno);
}
DEFUN ("file-selinux-context", Ffile_selinux_context,
@ -3083,7 +3141,7 @@ The return value is a list (USER ROLE TYPE RANGE), where the list
elements are strings naming the user, role, type, and range of the
file's SELinux security context.
Return (nil nil nil nil) if the file is nonexistent or inaccessible,
Return (nil nil nil nil) if the file is nonexistent,
or if SELinux is disabled, or if Emacs lacks SELinux support. */)
(Lisp_Object filename)
{
@ -3097,13 +3155,11 @@ or if SELinux is disabled, or if Emacs lacks SELinux support. */)
if (!NILP (handler))
return call2 (handler, Qfile_selinux_context, absname);
absname = ENCODE_FILE (absname);
#if HAVE_LIBSELINUX
if (is_selinux_enabled ())
{
security_context_t con;
int conlength = lgetfilecon (SSDATA (absname), &con);
int conlength = lgetfilecon (SSDATA (ENCODE_FILE (absname)), &con);
if (conlength > 0)
{
context_t context = context_new (con);
@ -3118,6 +3174,9 @@ or if SELinux is disabled, or if Emacs lacks SELinux support. */)
context_free (context);
freecon (con);
}
else if (! (errno == ENOENT || errno == ENOTDIR || errno == ENODATA
|| errno == ENOTSUP))
report_file_error ("getting SELinux context", absname);
}
#endif
@ -3213,8 +3272,7 @@ DEFUN ("file-acl", Ffile_acl, Sfile_acl, 1, 1, 0,
doc: /* Return ACL entries of file named FILENAME.
The entries are returned in a format suitable for use in `set-file-acl'
but is otherwise undocumented and subject to change.
Return nil if file does not exist or is not accessible, or if Emacs
was unable to determine the ACL entries. */)
Return nil if file does not exist. */)
(Lisp_Object filename)
{
Lisp_Object acl_string = Qnil;
@ -3229,20 +3287,22 @@ was unable to determine the ACL entries. */)
return call2 (handler, Qfile_acl, absname);
# ifdef HAVE_ACL_SET_FILE
absname = ENCODE_FILE (absname);
# ifndef HAVE_ACL_TYPE_EXTENDED
acl_type_t ACL_TYPE_EXTENDED = ACL_TYPE_ACCESS;
# endif
acl_t acl = acl_get_file (SSDATA (absname), ACL_TYPE_EXTENDED);
acl_t acl = acl_get_file (SSDATA (ENCODE_FILE (absname)), ACL_TYPE_EXTENDED);
if (acl == NULL)
return Qnil;
{
if (errno == ENOENT || errno == ENOTDIR || errno == ENOTSUP)
return Qnil;
report_file_error ("Getting ACLs", absname);
}
char *str = acl_to_text (acl, NULL);
if (str == NULL)
{
int err = errno;
acl_free (acl);
return Qnil;
report_file_errno ("Getting ACLs", absname, err);
}
acl_string = build_string (str);
@ -3313,7 +3373,7 @@ support. */)
DEFUN ("file-modes", Ffile_modes, Sfile_modes, 1, 1, 0,
doc: /* Return mode bits of file named FILENAME, as an integer.
Return nil, if file does not exist or is not accessible. */)
Return nil if FILENAME does not exist. */)
(Lisp_Object filename)
{
struct stat st;
@ -3325,11 +3385,8 @@ Return nil, if file does not exist or is not accessible. */)
if (!NILP (handler))
return call2 (handler, Qfile_modes, absname);
absname = ENCODE_FILE (absname);
if (stat (SSDATA (absname), &st) < 0)
return Qnil;
if (stat (SSDATA (ENCODE_FILE (absname)), &st) != 0)
return file_attribute_errno (absname, errno);
return make_fixnum (st.st_mode & 07777);
}
@ -3473,14 +3530,27 @@ otherwise, if FILE2 does not exist, the answer is t. */)
if (!NILP (handler))
return call3 (handler, Qfile_newer_than_file_p, absname1, absname2);
absname1 = ENCODE_FILE (absname1);
absname2 = ENCODE_FILE (absname2);
int err1;
if (stat (SSDATA (ENCODE_FILE (absname1)), &st1) == 0)
err1 = 0;
else
{
err1 = errno;
if (err1 != EOVERFLOW)
return file_test_errno (absname1, err1);
}
if (stat (SSDATA (absname1), &st1) < 0)
return Qnil;
if (stat (SSDATA (ENCODE_FILE (absname2)), &st2) != 0)
{
file_test_errno (absname2, errno);
return Qt;
}
if (stat (SSDATA (absname2), &st2) < 0)
return Qt;
if (err1)
{
file_test_errno (absname1, err1);
eassume (false);
}
return (timespec_cmp (get_stat_mtime (&st2), get_stat_mtime (&st1)) < 0
? Qt : Qnil);
@ -3612,7 +3682,7 @@ file_offset (Lisp_Object val)
static struct timespec
time_error_value (int errnum)
{
int ns = (errnum == ENOENT || errnum == EACCES || errnum == ENOTDIR
int ns = (errnum == ENOENT || errnum == ENOTDIR
? NONEXISTENT_MODTIME_NSECS
: UNKNOWN_MODTIME_NSECS);
return make_timespec (0, ns);
@ -5672,13 +5742,13 @@ in `current-time' or an integer flag as returned by `visited-file-modtime'. */)
/* The handler can find the file name the same way we did. */
return call2 (handler, Qset_visited_file_modtime, Qnil);
filename = ENCODE_FILE (filename);
if (stat (SSDATA (filename), &st) >= 0)
if (stat (SSDATA (ENCODE_FILE (filename)), &st) == 0)
{
current_buffer->modtime = get_stat_mtime (&st);
current_buffer->modtime_size = st.st_size;
}
else
file_attribute_errno (filename, errno);
}
return Qnil;
@ -5822,7 +5892,7 @@ A non-nil CURRENT-ONLY argument means save only current buffer. */)
if (!NILP (Vrun_hooks))
{
Lisp_Object dir;
dir = Ffile_name_directory (listfile);
dir = file_name_directory (listfile);
if (NILP (Ffile_directory_p (dir)))
internal_condition_case_1 (do_auto_save_make_dir,
dir, Qt,
@ -6067,16 +6137,18 @@ effect except for flushing STREAM's data. */)
#ifndef DOS_NT
/* Yield a Lisp float as close as possible to BLOCKSIZE * BLOCKS, with
the result negated if NEGATE. */
/* Yield a Lisp number equal to BLOCKSIZE * BLOCKS, with the result
negated if NEGATE. */
static Lisp_Object
blocks_to_bytes (uintmax_t blocksize, uintmax_t blocks, bool negate)
{
/* On typical platforms the following code is accurate to 53 bits,
which is close enough. BLOCKSIZE is invariably a power of 2, so
converting it to double does not lose information. */
double bs = blocksize;
return make_float (negate ? -bs * -blocks : bs * blocks);
intmax_t n;
if (!INT_MULTIPLY_WRAPV (blocksize, blocks, &n))
return make_int (negate ? -n : n);
Lisp_Object bs = make_uint (blocksize);
if (negate)
bs = CALLN (Fminus, bs);
return CALLN (Ftimes, bs, make_uint (blocks));
}
DEFUN ("file-system-info", Ffile_system_info, Sfile_system_info, 1, 1, 0,
@ -6087,22 +6159,22 @@ storage available to a non-superuser. All 3 numbers are in bytes.
If the underlying system call fails, value is nil. */)
(Lisp_Object filename)
{
Lisp_Object encoded = ENCODE_FILE (Fexpand_file_name (filename, Qnil));
filename = Fexpand_file_name (filename, Qnil);
/* If the file name has special constructs in it,
call the corresponding file name handler. */
Lisp_Object handler = Ffind_file_name_handler (encoded, Qfile_system_info);
Lisp_Object handler = Ffind_file_name_handler (filename, Qfile_system_info);
if (!NILP (handler))
{
Lisp_Object result = call2 (handler, Qfile_system_info, encoded);
Lisp_Object result = call2 (handler, Qfile_system_info, filename);
if (CONSP (result) || NILP (result))
return result;
error ("Invalid handler in `file-name-handler-alist'");
}
struct fs_usage u;
if (get_fs_usage (SSDATA (encoded), NULL, &u) != 0)
return Qnil;
if (get_fs_usage (SSDATA (ENCODE_FILE (filename)), NULL, &u) != 0)
return errno == ENOSYS ? Qnil : file_attribute_errno (filename, errno);
return list3 (blocks_to_bytes (u.fsu_blocksize, u.fsu_blocks, false),
blocks_to_bytes (u.fsu_blocksize, u.fsu_bfree, false),
blocks_to_bytes (u.fsu_blocksize, u.fsu_bavail,

86
src/filelock.c
View file

@ -504,9 +504,9 @@ read_lock_data (char *lfname, char lfinfo[MAX_LFINFO + 1])
}
/* Return 0 if nobody owns the lock file LFNAME or the lock is obsolete,
1 if another process owns it (and set OWNER (if non-null) to info),
2 if the current process owns it,
or -1 if something is wrong with the locking mechanism. */
-1 if another process owns it (and set OWNER (if non-null) to info),
-2 if the current process owns it,
or an errno value if something is wrong with the locking mechanism. */
static int
current_lock_owner (lock_info_type *owner, char *lfname)
@ -525,23 +525,23 @@ current_lock_owner (lock_info_type *owner, char *lfname)
/* If nonexistent lock file, all is well; otherwise, got strange error. */
lfinfolen = read_lock_data (lfname, owner->user);
if (lfinfolen < 0)
return errno == ENOENT ? 0 : -1;
return errno == ENOENT ? 0 : errno;
if (MAX_LFINFO < lfinfolen)
return -1;
return ENAMETOOLONG;
owner->user[lfinfolen] = 0;
/* Parse USER@HOST.PID:BOOT_TIME. If can't parse, return -1. */
/* Parse USER@HOST.PID:BOOT_TIME. If can't parse, return EINVAL. */
/* The USER is everything before the last @. */
owner->at = at = memrchr (owner->user, '@', lfinfolen);
if (!at)
return -1;
return EINVAL;
owner->dot = dot = strrchr (at, '.');
if (!dot)
return -1;
return EINVAL;
/* The PID is everything from the last '.' to the ':' or equivalent. */
if (! c_isdigit (dot[1]))
return -1;
return EINVAL;
errno = 0;
pid = strtoimax (dot + 1, &owner->colon, 10);
if (errno == ERANGE)
@ -562,20 +562,20 @@ current_lock_owner (lock_info_type *owner, char *lfname)
mistakenly transliterate ':' to U+F022 in symlink contents.
See <https://bugzilla.redhat.com/show_bug.cgi?id=1384153>. */
if (! (boot[0] == '\200' && boot[1] == '\242'))
return -1;
return EINVAL;
boot += 2;
FALLTHROUGH;
case ':':
if (! c_isdigit (boot[0]))
return -1;
return EINVAL;
boot_time = strtoimax (boot, &lfinfo_end, 10);
break;
default:
return -1;
return EINVAL;
}
if (lfinfo_end != owner->user + lfinfolen)
return -1;
return EINVAL;
/* On current host? */
Lisp_Object system_name = Fsystem_name ();
@ -584,22 +584,22 @@ current_lock_owner (lock_info_type *owner, char *lfname)
&& memcmp (at + 1, SSDATA (system_name), SBYTES (system_name)) == 0)
{
if (pid == getpid ())
ret = 2; /* We own it. */
ret = -2; /* We own it. */
else if (0 < pid && pid <= TYPE_MAXIMUM (pid_t)
&& (kill (pid, 0) >= 0 || errno == EPERM)
&& (boot_time == 0
|| (boot_time <= TYPE_MAXIMUM (time_t)
&& within_one_second (boot_time, get_boot_time ()))))
ret = 1; /* An existing process on this machine owns it. */
ret = -1; /* An existing process on this machine owns it. */
/* The owner process is dead or has a strange pid, so try to
zap the lockfile. */
else
return unlink (lfname);
return unlink (lfname) < 0 ? errno : 0;
}
else
{ /* If we wanted to support the check for stale locks on remote machines,
here's where we'd do it. */
ret = 1;
ret = -1;
}
return ret;
@ -608,9 +608,9 @@ current_lock_owner (lock_info_type *owner, char *lfname)
/* Lock the lock named LFNAME if possible.
Return 0 in that case.
Return positive if some other process owns the lock, and info about
Return negative if some other process owns the lock, and info about
that process in CLASHER.
Return -1 if cannot lock for any other reason. */
Return positive errno value if cannot lock for any other reason. */
static int
lock_if_free (lock_info_type *clasher, char *lfname)
@ -618,20 +618,18 @@ lock_if_free (lock_info_type *clasher, char *lfname)
int err;
while ((err = lock_file_1 (lfname, 0)) == EEXIST)
{
switch (current_lock_owner (clasher, lfname))
err = current_lock_owner (clasher, lfname);
if (err != 0)
{
case 2:
return 0; /* We ourselves locked it. */
case 1:
return 1; /* Someone else has it. */
case -1:
return -1; /* current_lock_owner returned strange error. */
if (err < 0)
return -2 - err; /* We locked it, or someone else has it. */
break; /* current_lock_owner returned strange error. */
}
/* We deleted a stale lock; try again to lock the file. */
}
return err ? -1 : 0;
return err;
}
/* lock_file locks file FN,
@ -697,8 +695,9 @@ lock_file (Lisp_Object fn)
/* Create the name of the lock-file for file fn */
MAKE_LOCK_NAME (lfname, encoded_fn);
/* Try to lock the lock. */
if (0 < lock_if_free (&lock_info, lfname))
/* Try to lock the lock. FIXME: This ignores errors when
lock_if_free returns a positive errno value. */
if (lock_if_free (&lock_info, lfname) < 0)
{
/* Someone else has the lock. Consider breaking it. */
Lisp_Object attack;
@ -725,13 +724,16 @@ unlock_file (Lisp_Object fn)
char *lfname;
USE_SAFE_ALLOCA;
fn = Fexpand_file_name (fn, Qnil);
fn = ENCODE_FILE (fn);
Lisp_Object filename = Fexpand_file_name (fn, Qnil);
fn = ENCODE_FILE (filename);
MAKE_LOCK_NAME (lfname, fn);
if (current_lock_owner (0, lfname) == 2)
unlink (lfname);
int err = current_lock_owner (0, lfname);
if (err == -2 && unlink (lfname) != 0 && errno != ENOENT)
err = errno;
if (0 < err)
report_file_errno ("Unlocking file", filename, err);
SAFE_FREE ();
}
@ -822,17 +824,17 @@ t if it is locked by you, else a string saying which user has locked it. */)
USE_SAFE_ALLOCA;
filename = Fexpand_file_name (filename, Qnil);
filename = ENCODE_FILE (filename);
MAKE_LOCK_NAME (lfname, filename);
Lisp_Object encoded_filename = ENCODE_FILE (filename);
MAKE_LOCK_NAME (lfname, encoded_filename);
owner = current_lock_owner (&locker, lfname);
if (owner <= 0)
ret = Qnil;
else if (owner == 2)
ret = Qt;
else
ret = make_string (locker.user, locker.at - locker.user);
switch (owner)
{
case -2: ret = Qt; break;
case -1: ret = make_string (locker.user, locker.at - locker.user); break;
case 0: ret = Qnil; break;
default: report_file_errno ("Testing file lock", filename, owner);
}
SAFE_FREE ();
return ret;

3
src/fns.c
View file

@ -532,14 +532,12 @@ Do NOT use this function to compare file names for equality. */)
static Lisp_Object concat (ptrdiff_t nargs, Lisp_Object *args,
enum Lisp_Type target_type, bool last_special);
/* ARGSUSED */
Lisp_Object
concat2 (Lisp_Object s1, Lisp_Object s2)
{
return concat (2, ((Lisp_Object []) {s1, s2}), Lisp_String, 0);
}
/* ARGSUSED */
Lisp_Object
concat3 (Lisp_Object s1, Lisp_Object s2, Lisp_Object s3)
{
@ -2577,7 +2575,6 @@ This makes STRING unibyte and may change its length. */)
return Qnil;
}
/* ARGSUSED */
Lisp_Object
nconc2 (Lisp_Object s1, Lisp_Object s2)
{

10
src/lisp.h
View file

@ -3824,9 +3824,10 @@ extern void mark_maybe_objects (Lisp_Object const *, ptrdiff_t);
extern void mark_stack (char const *, char const *);
extern void flush_stack_call_func (void (*func) (void *arg), void *arg);
extern void garbage_collect (void);
extern void maybe_garbage_collect (void);
extern const char *pending_malloc_warning;
extern Lisp_Object zero_vector;
extern intmax_t consing_until_gc;
extern EMACS_INT consing_until_gc;
#ifdef HAVE_PDUMPER
extern int number_finalizers_run;
#endif
@ -4308,12 +4309,15 @@ extern Lisp_Object write_region (Lisp_Object, Lisp_Object, Lisp_Object,
extern void close_file_unwind (int);
extern void fclose_unwind (void *);
extern void restore_point_unwind (Lisp_Object);
extern bool file_access_p (char const *, int);
extern Lisp_Object get_file_errno_data (const char *, Lisp_Object, int);
extern AVOID report_file_errno (const char *, Lisp_Object, int);
extern AVOID report_file_error (const char *, Lisp_Object);
extern AVOID report_file_notify_error (const char *, Lisp_Object);
extern Lisp_Object file_attribute_errno (Lisp_Object, int);
extern Lisp_Object file_test_errno (Lisp_Object, int);
extern bool internal_delete_file (Lisp_Object);
extern Lisp_Object emacs_readlinkat (int, const char *);
extern Lisp_Object check_emacs_readlinkat (int, Lisp_Object, char const *);
extern bool file_directory_p (Lisp_Object);
extern bool file_accessible_directory_p (Lisp_Object);
extern void init_fileio (void);
@ -5055,7 +5059,7 @@ INLINE void
maybe_gc (void)
{
if (consing_until_gc < 0)
garbage_collect ();
maybe_garbage_collect ();
}
INLINE_HEADER_END

22
src/lread.c
View file

@ -1343,18 +1343,26 @@ Return t if the file exists and loads successfully. */)
/* openp already checked for newness, no point doing it again.
FIXME would be nice to get a message when openp
ignores suffix order due to load_prefer_newer. */
Lisp_Object notfound = found;
if (!load_prefer_newer && is_elc)
{
result = stat (SSDATA (efound), &s1);
int err = errno;
if (result == 0)
{
SSET (efound, SBYTES (efound) - 1, 0);
result = stat (SSDATA (efound), &s2);
err = errno;
SSET (efound, SBYTES (efound) - 1, 'c');
if (result != 0)
notfound = Fsubstring (found, make_fixnum (0),
make_fixnum (-1));
}
if (result == 0
&& timespec_cmp (get_stat_mtime (&s1), get_stat_mtime (&s2)) < 0)
if (result != 0)
file_test_errno (notfound, err);
else if (timespec_cmp (get_stat_mtime (&s1),
get_stat_mtime (&s2))
< 0)
{
/* Make the progress messages mention that source is newer. */
newer = 1;
@ -1748,16 +1756,20 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes,
{
if (file_directory_p (encoded_fn))
last_errno = EISDIR;
else
else if (errno == ENOENT || errno == ENOTDIR)
fd = 1;
else
last_errno = errno;
}
else if (! (errno == ENOENT || errno == ENOTDIR))
last_errno = errno;
}
else
{
fd = emacs_open (pfn, O_RDONLY, 0);
if (fd < 0)
{
if (errno != ENOENT)
if (! (errno == ENOENT || errno == ENOTDIR))
last_errno = errno;
}
else

11
src/pdumper.c
View file

@ -5303,7 +5303,7 @@ enum dump_section
N.B. We run very early in initialization, so we can't use lisp,
unwinding, xmalloc, and so on. */
enum pdumper_load_result
int
pdumper_load (const char *dump_filename)
{
intptr_t dump_size;
@ -5328,10 +5328,15 @@ pdumper_load (const char *dump_filename)
/* We can load only one dump. */
eassert (!dump_loaded_p ());
enum pdumper_load_result err = PDUMPER_LOAD_FILE_NOT_FOUND;
int err;
int dump_fd = emacs_open (dump_filename, O_RDONLY, 0);
if (dump_fd < 0)
goto out;
{
err = (errno == ENOENT || errno == ENOTDIR
? PDUMPER_LOAD_FILE_NOT_FOUND
: PDUMPER_LOAD_ERROR + errno);
goto out;
}
err = PDUMPER_LOAD_FILE_NOT_FOUND;
if (fstat (dump_fd, &stat) < 0)

4
src/pdumper.h
View file

@ -124,10 +124,10 @@ enum pdumper_load_result
PDUMPER_LOAD_FAILED_DUMP,
PDUMPER_LOAD_OOM,
PDUMPER_LOAD_VERSION_MISMATCH,
PDUMPER_LOAD_ERROR,
PDUMPER_LOAD_ERROR /* Must be last, as errno may be added. */
};
enum pdumper_load_result pdumper_load (const char *dump_filename);
int pdumper_load (const char *dump_filename);
struct pdumper_loaded_dump
{

100
src/print.c
View file

@ -81,7 +81,7 @@ static ptrdiff_t print_buffer_pos_byte;
-N the object will be printed several times and will take number N.
N the object has been printed so we can refer to it as #N#.
print_number_index holds the largest N already used.
N has to be striclty larger than 0 since we need to distinguish -N. */
N has to be strictly larger than 0 since we need to distinguish -N. */
static ptrdiff_t print_number_index;
static void print_interval (INTERVAL interval, Lisp_Object printcharfun);
@ -1120,8 +1120,8 @@ print (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
Vprint_number_table = Qnil;
}
/* Construct Vprint_number_table for print-gensym and print-circle. */
if (!NILP (Vprint_gensym) || !NILP (Vprint_circle))
/* Construct Vprint_number_table for print-circle. */
if (!NILP (Vprint_circle))
{
/* Construct Vprint_number_table.
This increments print_number_index for the objects added. */
@ -1149,7 +1149,11 @@ print (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
}
#define PRINT_CIRCLE_CANDIDATE_P(obj) \
(STRINGP (obj) || CONSP (obj) \
((STRINGP (obj) \
&& (string_intervals (obj) \
|| print_depth > 1 \
|| !NILP (Vprint_continuous_numbering))) \
|| CONSP (obj) \
|| (VECTORLIKEP (obj) \
&& (VECTORP (obj) || COMPILEDP (obj) \
|| CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj) \
@ -1159,13 +1163,14 @@ print (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
&& SYMBOLP (obj) \
&& !SYMBOL_INTERNED_P (obj)))
/* Construct Vprint_number_table according to the structure of OBJ.
OBJ itself and all its elements will be added to Vprint_number_table
recursively if it is a list, vector, compiled function, char-table,
string (its text properties will be traced), or a symbol that has
no obarray (this is for the print-gensym feature).
The status fields of Vprint_number_table mean whether each object appears
more than once in OBJ: Qnil at the first time, and Qt after that. */
/* Construct Vprint_number_table for the print-circle feature
according to the structure of OBJ. OBJ itself and all its elements
will be added to Vprint_number_table recursively if it is a list,
vector, compiled function, char-table, string (its text properties
will be traced), or a symbol that has no obarray (this is for the
print-gensym feature). The status fields of Vprint_number_table
mean whether each object appears more than once in OBJ: Qnil at the
first time, and Qt after that. */
static void
print_preprocess (Lisp_Object obj)
{
@ -1174,20 +1179,7 @@ print_preprocess (Lisp_Object obj)
int loop_count = 0;
Lisp_Object halftail;
/* Avoid infinite recursion for circular nested structure
in the case where Vprint_circle is nil. */
if (NILP (Vprint_circle))
{
/* Give up if we go so deep that print_object will get an error. */
/* See similar code in print_object. */
if (print_depth >= PRINT_CIRCLE)
error ("Apparently circular structure being printed");
for (i = 0; i < print_depth; i++)
if (EQ (obj, being_printed[i]))
return;
being_printed[print_depth] = obj;
}
eassert (!NILP (Vprint_circle));
print_depth++;
halftail = obj;
@ -1198,33 +1190,28 @@ print_preprocess (Lisp_Object obj)
if (!HASH_TABLE_P (Vprint_number_table))
Vprint_number_table = CALLN (Fmake_hash_table, QCtest, Qeq);
/* In case print-circle is nil and print-gensym is t,
add OBJ to Vprint_number_table only when OBJ is a symbol. */
if (! NILP (Vprint_circle) || SYMBOLP (obj))
{
Lisp_Object num = Fgethash (obj, Vprint_number_table, Qnil);
if (!NILP (num)
/* If Vprint_continuous_numbering is non-nil and OBJ is a gensym,
always print the gensym with a number. This is a special for
the lisp function byte-compile-output-docform. */
|| (!NILP (Vprint_continuous_numbering)
&& SYMBOLP (obj)
&& !SYMBOL_INTERNED_P (obj)))
{ /* OBJ appears more than once. Let's remember that. */
if (!FIXNUMP (num))
{
print_number_index++;
/* Negative number indicates it hasn't been printed yet. */
Fputhash (obj, make_fixnum (- print_number_index),
Vprint_number_table);
}
print_depth--;
return;
Lisp_Object num = Fgethash (obj, Vprint_number_table, Qnil);
if (!NILP (num)
/* If Vprint_continuous_numbering is non-nil and OBJ is a gensym,
always print the gensym with a number. This is a special for
the lisp function byte-compile-output-docform. */
|| (!NILP (Vprint_continuous_numbering)
&& SYMBOLP (obj)
&& !SYMBOL_INTERNED_P (obj)))
{ /* OBJ appears more than once. Let's remember that. */
if (!FIXNUMP (num))
{
print_number_index++;
/* Negative number indicates it hasn't been printed yet. */
Fputhash (obj, make_fixnum (- print_number_index),
Vprint_number_table);
}
else
/* OBJ is not yet recorded. Let's add to the table. */
Fputhash (obj, Qt, Vprint_number_table);
print_depth--;
return;
}
else
/* OBJ is not yet recorded. Let's add to the table. */
Fputhash (obj, Qt, Vprint_number_table);
switch (XTYPE (obj))
{
@ -1271,11 +1258,15 @@ print_preprocess (Lisp_Object obj)
DEFUN ("print--preprocess", Fprint_preprocess, Sprint_preprocess, 1, 1, 0,
doc: /* Extract sharing info from OBJECT needed to print it.
Fills `print-number-table'. */)
(Lisp_Object object)
Fills `print-number-table' if `print-circle' is non-nil. Does nothing
if `print-circle' is nil. */)
(Lisp_Object object)
{
print_number_index = 0;
print_preprocess (object);
if (!NILP (Vprint_circle))
{
print_number_index = 0;
print_preprocess (object);
}
return Qnil;
}
@ -1860,7 +1851,6 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
/* Simple but incomplete way. */
int i;
/* See similar code in print_preprocess. */
if (print_depth >= PRINT_CIRCLE)
error ("Apparently circular structure being printed");

12
src/profiler.c
View file

@ -66,11 +66,11 @@ make_log (void)
Qnil, false);
struct Lisp_Hash_Table *h = XHASH_TABLE (log);
/* What is special about our hash-tables is that the keys are pre-filled
with the vectors we'll put in them. */
/* What is special about our hash-tables is that the values are pre-filled
with the vectors we'll use as keys. */
ptrdiff_t i = ASIZE (h->key_and_value) >> 1;
while (i > 0)
set_hash_key_slot (h, --i, make_nil_vector (max_stack_depth));
set_hash_value_slot (h, --i, make_nil_vector (max_stack_depth));
return log;
}
@ -132,13 +132,14 @@ static void evict_lower_half (log_t *log)
XSET_HASH_TABLE (tmp, log); /* FIXME: Use make_lisp_ptr. */
Fremhash (key, tmp);
}
eassert (EQ (Qunbound, HASH_KEY (log, i)));
eassert (log->next_free == i);
eassert (VECTORP (key));
for (ptrdiff_t j = 0; j < ASIZE (key); j++)
ASET (key, j, Qnil);
set_hash_key_slot (log, i, key);
set_hash_value_slot (log, i, key);
}
}
@ -156,7 +157,8 @@ record_backtrace (log_t *log, EMACS_INT count)
ptrdiff_t index = log->next_free;
/* Get a "working memory" vector. */
Lisp_Object backtrace = HASH_KEY (log, index);
Lisp_Object backtrace = HASH_VALUE (log, index);
eassert (EQ (Qunbound, HASH_KEY (log, index)));
get_backtrace (backtrace);
{ /* We basically do a `gethash+puthash' here, except that we have to be

1
src/term.c
View file

@ -1084,7 +1084,6 @@ int *char_ins_del_vector;
#define char_ins_del_cost(f) (&char_ins_del_vector[FRAME_COLS ((f))])
/* ARGSUSED */
static void
calculate_ins_del_char_costs (struct frame *f)
{

29
src/w32.c
View file

@ -4151,13 +4151,36 @@ w32_accessible_directory_p (const char *dirname, ptrdiff_t dirlen)
/* In case DIRNAME cannot be expressed in characters from the
current ANSI codepage. */
if (_mbspbrk (pat_a, "?"))
dh = INVALID_HANDLE_VALUE;
else
dh = FindFirstFileA (pat_a, &dfd_a);
{
errno = ENOENT;
return 0;
}
dh = FindFirstFileA (pat_a, &dfd_a);
}
if (dh == INVALID_HANDLE_VALUE)
{
DWORD w32err = GetLastError ();
switch (w32err)
{
case ERROR_INVALID_NAME:
case ERROR_BAD_PATHNAME:
case ERROR_FILE_NOT_FOUND:
case ERROR_PATH_NOT_FOUND:
case ERROR_NO_MORE_FILES:
case ERROR_BAD_NETPATH:
errno = ENOENT;
break;
case ERROR_NOT_READY:
errno = ENODEV;
break;
default:
errno = EACCES;
break;
}
return 0;
}
FindClose (dh);
return 1;
}

4
src/w32fns.c
View file

@ -10109,8 +10109,8 @@ KEY can use either forward- or back-slashes.
To access the default value of KEY (if it is defined), use NAME
that is an empty string.
If the the named KEY or its subkey called NAME don't exist, or cannot
be accessed by the current user, the function returns nil. Otherwise,
If the named KEY or its subkey called NAME don't exist, or cannot be
accessed by the current user, the function returns nil. Otherwise,
the return value depends on the type of the data stored in Registry:
If the data type is REG_NONE, the function returns t.

125
src/w32font.c
View file

@ -90,6 +90,8 @@ struct font_callback_data
Lisp_Object orig_font_spec;
/* The frame the font is being loaded on. */
Lisp_Object frame;
/* Fonts known to support the font spec, or nil if none. */
Lisp_Object known_fonts;
/* The list to add matches to. */
Lisp_Object list;
/* Whether to match only opentype fonts. */
@ -841,6 +843,25 @@ w32font_list_internal (struct frame *f, Lisp_Object font_spec,
match_data.opentype_only = opentype_only;
if (opentype_only)
match_data.pattern.lfOutPrecision = OUT_OUTLINE_PRECIS;
match_data.known_fonts = Qnil;
Lisp_Object vw32_non_USB_fonts = Fsymbol_value (Qw32_non_USB_fonts), val;
if (CONSP (vw32_non_USB_fonts))
{
Lisp_Object extra;
for (extra = AREF (font_spec, FONT_EXTRA_INDEX);
CONSP (extra); extra = XCDR (extra))
{
Lisp_Object tem = XCAR (extra);
if (CONSP (tem)
&& EQ (XCAR (tem), QCscript)
&& SYMBOLP (XCDR (tem))
&& !NILP (val = assq_no_quit (XCDR (tem), vw32_non_USB_fonts)))
{
match_data.known_fonts = XCDR (val);
break;
}
}
}
if (match_data.pattern.lfFaceName[0] == '\0')
{
@ -890,6 +911,26 @@ w32font_match_internal (struct frame *f, Lisp_Object font_spec,
if (opentype_only)
match_data.pattern.lfOutPrecision = OUT_OUTLINE_PRECIS;
match_data.known_fonts = Qnil;
Lisp_Object vw32_non_USB_fonts = Fsymbol_value (Qw32_non_USB_fonts), val;
if (CONSP (vw32_non_USB_fonts))
{
Lisp_Object extra;
for (extra = AREF (font_spec, FONT_EXTRA_INDEX);
CONSP (extra); extra = XCDR (extra))
{
Lisp_Object tem = XCAR (extra);
if (CONSP (tem)
&& EQ (XCAR (tem), QCscript)
&& SYMBOLP (XCDR (tem))
&& !NILP (val = assq_no_quit (XCDR (tem), vw32_non_USB_fonts)))
{
match_data.known_fonts = XCDR (val);
break;
}
}
}
/* Prevent quitting while EnumFontFamiliesEx runs and conses the
list it will return. That's because get_frame_dc acquires the
critical section, so we cannot quit before we release it in
@ -1511,9 +1552,13 @@ add_font_entity_to_list (ENUMLOGFONTEX *logical_font,
/* Ensure a match. */
if (!logfonts_match (&logical_font->elfLogFont, &match_data->pattern)
|| !font_matches_spec (font_type, physical_font,
match_data->orig_font_spec, backend,
&logical_font->elfLogFont)
|| !(font_matches_spec (font_type, physical_font,
match_data->orig_font_spec, backend,
&logical_font->elfLogFont)
|| (!NILP (match_data->known_fonts)
&& memq_no_quit
(intern_font_name (logical_font->elfLogFont.lfFaceName),
match_data->known_fonts)))
|| !w32font_coverage_ok (&physical_font->ntmFontSig,
match_data->pattern.lfCharSet))
return 1;
@ -2214,8 +2259,9 @@ font_supported_scripts (FONTSIGNATURE * sig)
|| (subranges[2] & (mask2)) || (subranges[3] & (mask3))) \
supported = Fcons ((sym), supported)
SUBRANGE (0, Qlatin);
/* 1: Latin-1 supplement, 2: Latin Extended A, 3: Latin Extended B. */
/* 0: ASCII (a.k.a. "Basic Latin"),
1: Latin-1 supplement, 2: Latin Extended A, 3: Latin Extended B,
29: Latin Extended Additional. */
/* Most fonts that support Latin will have good coverage of the
Extended blocks, so in practice marking them below is not really
needed, or useful: if a font claims support for, say, Latin
@ -2224,12 +2270,11 @@ font_supported_scripts (FONTSIGNATURE * sig)
fontset to display those few characters. But we mark these
subranges here anyway, for the marginal use cases where they
might make a difference. */
SUBRANGE (1, Qlatin);
SUBRANGE (2, Qlatin);
SUBRANGE (3, Qlatin);
MASK_ANY (0x2000000F, 0, 0, 0, Qlatin);
SUBRANGE (4, Qphonetic);
/* 5: Spacing and tone modifiers, 6: Combining Diacritical Marks. */
SUBRANGE (7, Qgreek);
/* 7: Greek and Coptic, 30: Greek Extended. */
MASK_ANY (0x40000080, 0, 0, 0, Qgreek);
SUBRANGE (8, Qcoptic);
SUBRANGE (9, Qcyrillic);
SUBRANGE (10, Qarmenian);
@ -2246,7 +2291,7 @@ font_supported_scripts (FONTSIGNATURE * sig)
SUBRANGE (16, Qbengali);
SUBRANGE (17, Qgurmukhi);
SUBRANGE (18, Qgujarati);
SUBRANGE (19, Qoriya);
SUBRANGE (19, Qoriya); /* a.k.a. "Odia" */
SUBRANGE (20, Qtamil);
SUBRANGE (21, Qtelugu);
SUBRANGE (22, Qkannada);
@ -2259,8 +2304,7 @@ font_supported_scripts (FONTSIGNATURE * sig)
/* 29: Latin Extended, 30: Greek Extended -- covered above. */
/* 31: Supplemental Punctuation -- most probably be masked by
Courier New, so fontset customization is needed. */
SUBRANGE (31, Qsymbol);
/* 32-47: Symbols (defined below). */
/* 31-47: Symbols (defined below). */
SUBRANGE (48, Qcjk_misc);
/* Match either 49: katakana or 50: hiragana for kana. */
MASK_ANY (0, 0x00060000, 0, 0, Qkana);
@ -2286,7 +2330,7 @@ font_supported_scripts (FONTSIGNATURE * sig)
SUBRANGE (71, Qsyriac);
SUBRANGE (72, Qthaana);
SUBRANGE (73, Qsinhala);
SUBRANGE (74, Qmyanmar);
SUBRANGE (74, Qburmese); /* a.k.a. "Myanmar" */
SUBRANGE (75, Qethiopic);
SUBRANGE (76, Qcherokee);
SUBRANGE (77, Qcanadian_aboriginal);
@ -2329,6 +2373,7 @@ font_supported_scripts (FONTSIGNATURE * sig)
SUBRANGE (99, Qhan);
SUBRANGE (100, Qsyloti_nagri);
SUBRANGE (101, Qlinear_b);
SUBRANGE (101, Qaegean_number);
SUBRANGE (102, Qancient_greek_number);
SUBRANGE (103, Qugaritic);
SUBRANGE (104, Qold_persian);
@ -2338,6 +2383,7 @@ font_supported_scripts (FONTSIGNATURE * sig)
SUBRANGE (108, Qkharoshthi);
SUBRANGE (109, Qtai_xuan_jing_symbol);
SUBRANGE (110, Qcuneiform);
SUBRANGE (111, Qcuneiform_numbers_and_punctuation);
SUBRANGE (111, Qcounting_rod_numeral);
SUBRANGE (112, Qsundanese);
SUBRANGE (113, Qlepcha);
@ -2357,9 +2403,52 @@ font_supported_scripts (FONTSIGNATURE * sig)
/* There isn't really a main symbol range, so include symbol if any
relevant range is set. */
MASK_ANY (0x8000000, 0x0000FFFF, 0, 0, Qsymbol);
MASK_ANY (0x80000000, 0x0000FFFF, 0, 0, Qsymbol);
/* Missing: Tai Viet (U+AA80-U+AADF). */
/* Missing:
Tai Viet
Old Permic
Palmyrene
Nabatean
Manichean
Hanifi Rohingya
Sogdian
Elymaic
Mahajani
Khojki
Khudawadi
Grantha
Newa
Tirhuta
Siddham
Modi
Takri
Dogra
Warang Citi
Nandinagari
Zanabazar Square
Soyombo
Pau Cin Hau
Bhaiksuki
Marchen
Masaram Gondi
Makasar
Egyptian
Mro
Bassa-Vah
Pahawh Hmong
Medefaidrin
Tangut
Tangut Components
Nushu
Duployan Shorthand
Ancient Greek Musical Notation
Nyiakeng Puachue Hmong
Wancho
Mende Kikakui
Adlam
Indic Siyaq Number
Ottoman Siyaq Number. */
#undef SUBRANGE
#undef MASK_ANY
@ -2698,7 +2787,7 @@ syms_of_w32font (void)
DEFSYM (Qthai, "thai");
DEFSYM (Qlao, "lao");
DEFSYM (Qtibetan, "tibetan");
DEFSYM (Qmyanmar, "myanmar");
DEFSYM (Qburmese, "burmese");
DEFSYM (Qgeorgian, "georgian");
DEFSYM (Qhangul, "hangul");
DEFSYM (Qethiopic, "ethiopic");
@ -2737,6 +2826,8 @@ syms_of_w32font (void)
DEFSYM (Qbuginese, "buginese");
DEFSYM (Qbuhid, "buhid");
DEFSYM (Qcuneiform, "cuneiform");
DEFSYM (Qcuneiform_numbers_and_punctuation,
"cuneiform-numbers-and-punctuation");
DEFSYM (Qcypriot, "cypriot");
DEFSYM (Qdeseret, "deseret");
DEFSYM (Qglagolitic, "glagolitic");
@ -2745,6 +2836,7 @@ syms_of_w32font (void)
DEFSYM (Qkharoshthi, "kharoshthi");
DEFSYM (Qlimbu, "limbu");
DEFSYM (Qlinear_b, "linear_b");
DEFSYM (Qaegean_number, "aegean-number");
DEFSYM (Qold_italic, "old_italic");
DEFSYM (Qold_persian, "old_persian");
DEFSYM (Qosmanya, "osmanya");
@ -2818,6 +2910,7 @@ versions of Windows) characters. */);
DEFSYM (Qw32_charset_vietnamese, "w32-charset-vietnamese");
DEFSYM (Qw32_charset_thai, "w32-charset-thai");
DEFSYM (Qw32_charset_mac, "w32-charset-mac");
DEFSYM (Qw32_non_USB_fonts, "w32-non-USB-fonts");
defsubr (&Sx_select_font);

8
src/xdisp.c
View file

@ -12907,7 +12907,8 @@ tool_bar_height (struct frame *f, int *n_rows, bool pixelwise)
temp_row->reversed_p = false;
it.first_visible_x = 0;
it.last_visible_x = WINDOW_PIXEL_WIDTH (w);
reseat_to_string (&it, NULL, f->desired_tool_bar_string, 0, 0, 0, -1);
reseat_to_string (&it, NULL, f->desired_tool_bar_string,
0, 0, 0, STRING_MULTIBYTE (f->desired_tool_bar_string));
it.paragraph_embedding = L2R;
while (!ITERATOR_AT_END_P (&it))
@ -12994,7 +12995,8 @@ redisplay_tool_bar (struct frame *f)
/* Build a string that represents the contents of the tool-bar. */
build_desired_tool_bar_string (f);
reseat_to_string (&it, NULL, f->desired_tool_bar_string, 0, 0, 0, -1);
reseat_to_string (&it, NULL, f->desired_tool_bar_string,
0, 0, 0, STRING_MULTIBYTE (f->desired_tool_bar_string));
/* FIXME: This should be controlled by a user option. But it
doesn't make sense to have an R2L tool bar if the menu bar cannot
be drawn also R2L, and making the menu bar R2L is tricky due
@ -23531,7 +23533,7 @@ display_menu_bar (struct window *w)
/* Display the item, pad with one space. */
if (it.current_x < it.last_visible_x)
display_string (NULL, string, Qnil, 0, 0, &it,
SCHARS (string) + 1, 0, 0, -1);
SCHARS (string) + 1, 0, 0, STRING_MULTIBYTE (string));
}
/* Fill out the line with spaces. */

211
src/xwidget.c
View file

@ -31,14 +31,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <webkit2/webkit2.h>
#include <JavaScriptCore/JavaScript.h>
/* Suppress GCC deprecation warnings starting in WebKitGTK+ 2.21.1 for
webkit_javascript_result_get_global_context and
webkit_javascript_result_get_value (Bug#33679).
FIXME: Use the JavaScriptCore GLib API instead, and remove this hack. */
#if WEBKIT_CHECK_VERSION (2, 21, 1) && GNUC_PREREQ (4, 2, 0)
# pragma GCC diagnostic ignored "-Wdeprecated-declarations"
#endif
static struct xwidget *
allocate_xwidget (void)
{
@ -284,95 +276,70 @@ webkit_view_load_changed_cb (WebKitWebView *webkitwebview,
/* Recursively convert a JavaScript value to a Lisp value. */
static Lisp_Object
webkit_js_to_lisp (JSContextRef context, JSValueRef value)
webkit_js_to_lisp (JSCValue *value)
{
switch (JSValueGetType (context, value))
if (jsc_value_is_string (value))
{
case kJSTypeString:
{
JSStringRef js_str_value;
gchar *str_value;
gsize str_length;
gchar *str_value = jsc_value_to_string (value);
Lisp_Object ret = build_string (str_value);
g_free (str_value);
js_str_value = JSValueToStringCopy (context, value, NULL);
str_length = JSStringGetMaximumUTF8CStringSize (js_str_value);
str_value = (gchar *)g_malloc (str_length);
JSStringGetUTF8CString (js_str_value, str_value, str_length);
JSStringRelease (js_str_value);
return build_string (str_value);
}
case kJSTypeBoolean:
return (JSValueToBoolean (context, value)) ? Qt : Qnil;
case kJSTypeNumber:
return make_fixnum (JSValueToNumber (context, value, NULL));
case kJSTypeObject:
{
if (JSValueIsArray (context, value))
{
JSStringRef pname = JSStringCreateWithUTF8CString("length");
JSValueRef len = JSObjectGetProperty (context, (JSObjectRef) value,
pname, NULL);
double dlen = JSValueToNumber (context, len, NULL);
JSStringRelease(pname);
Lisp_Object obj;
if (! (0 <= dlen && dlen < PTRDIFF_MAX + 1.0))
memory_full (SIZE_MAX);
ptrdiff_t n = dlen;
struct Lisp_Vector *p = allocate_vector (n);
for (ptrdiff_t i = 0; i < n; ++i)
{
p->contents[i] =
webkit_js_to_lisp (context,
JSObjectGetPropertyAtIndex (context,
(JSObjectRef) value,
i, NULL));
}
XSETVECTOR (obj, p);
return obj;
}
else
{
JSPropertyNameArrayRef properties =
JSObjectCopyPropertyNames (context, (JSObjectRef) value);
size_t n = JSPropertyNameArrayGetCount (properties);
Lisp_Object obj;
/* TODO: can we use a regular list here? */
if (PTRDIFF_MAX < n)
memory_full (n);
struct Lisp_Vector *p = allocate_vector (n);
for (ptrdiff_t i = 0; i < n; ++i)
{
JSStringRef name = JSPropertyNameArrayGetNameAtIndex (properties, i);
JSValueRef property = JSObjectGetProperty (context,
(JSObjectRef) value,
name, NULL);
gchar *str_name;
gsize str_length;
str_length = JSStringGetMaximumUTF8CStringSize (name);
str_name = (gchar *)g_malloc (str_length);
JSStringGetUTF8CString (name, str_name, str_length);
JSStringRelease (name);
p->contents[i] =
Fcons (build_string (str_name),
webkit_js_to_lisp (context, property));
}
JSPropertyNameArrayRelease (properties);
XSETVECTOR (obj, p);
return obj;
}
}
case kJSTypeUndefined:
case kJSTypeNull:
default:
return Qnil;
return ret;
}
else if (jsc_value_is_boolean (value))
{
return (jsc_value_to_boolean (value)) ? Qt : Qnil;
}
else if (jsc_value_is_number (value))
{
return make_fixnum (jsc_value_to_int32 (value));
}
else if (jsc_value_is_array (value))
{
JSCValue *len = jsc_value_object_get_property (value, "length");
const gint32 dlen = jsc_value_to_int32 (len);
Lisp_Object obj;
if (! (0 <= dlen && dlen < PTRDIFF_MAX + 1.0))
memory_full (SIZE_MAX);
ptrdiff_t n = dlen;
struct Lisp_Vector *p = allocate_vector (n);
for (ptrdiff_t i = 0; i < n; ++i)
{
p->contents[i] =
webkit_js_to_lisp (jsc_value_object_get_property_at_index (value, i));
}
XSETVECTOR (obj, p);
return obj;
}
else if (jsc_value_is_object (value))
{
char **properties_names = jsc_value_object_enumerate_properties (value);
guint n = g_strv_length (properties_names);
Lisp_Object obj;
if (PTRDIFF_MAX < n)
memory_full (n);
struct Lisp_Vector *p = allocate_vector (n);
for (ptrdiff_t i = 0; i < n; ++i)
{
const char *name = properties_names[i];
JSCValue *property = jsc_value_object_get_property (value, name);
p->contents[i] =
Fcons (build_string (name), webkit_js_to_lisp (property));
}
g_strfreev (properties_names);
XSETVECTOR (obj, p);
return obj;
}
return Qnil;
}
static void
@ -380,41 +347,39 @@ webkit_javascript_finished_cb (GObject *webview,
GAsyncResult *result,
gpointer arg)
{
WebKitJavascriptResult *js_result;
JSValueRef value;
JSGlobalContextRef context;
GError *error = NULL;
struct xwidget *xw = g_object_get_data (G_OBJECT (webview),
XG_XWIDGET);
ptrdiff_t script_idx = (intptr_t) arg;
Lisp_Object script_callback = AREF (xw->script_callbacks, script_idx);
ASET (xw->script_callbacks, script_idx, Qnil);
if (!NILP (script_callback))
xfree (xmint_pointer (XCAR (script_callback)));
GError *error = NULL;
struct xwidget *xw = g_object_get_data (G_OBJECT (webview), XG_XWIDGET);
js_result = webkit_web_view_run_javascript_finish
(WEBKIT_WEB_VIEW (webview), result, &error);
ptrdiff_t script_idx = (intptr_t) arg;
Lisp_Object script_callback = AREF (xw->script_callbacks, script_idx);
ASET (xw->script_callbacks, script_idx, Qnil);
if (!NILP (script_callback))
xfree (xmint_pointer (XCAR (script_callback)));
if (!js_result)
{
g_warning ("Error running javascript: %s", error->message);
g_error_free (error);
return;
}
WebKitJavascriptResult *js_result =
webkit_web_view_run_javascript_finish
(WEBKIT_WEB_VIEW (webview), result, &error);
if (!NILP (script_callback) && !NILP (XCDR (script_callback)))
{
context = webkit_javascript_result_get_global_context (js_result);
value = webkit_javascript_result_get_value (js_result);
Lisp_Object lisp_value = webkit_js_to_lisp (context, value);
if (!js_result)
{
g_warning ("Error running javascript: %s", error->message);
g_error_free (error);
return;
}
/* Register an xwidget event here, which then runs the callback.
This ensures that the callback runs in sync with the Emacs
event loop. */
store_xwidget_js_callback_event (xw, XCDR (script_callback), lisp_value);
}
if (!NILP (script_callback) && !NILP (XCDR (script_callback)))
{
JSCValue *value = webkit_javascript_result_get_js_value (js_result);
webkit_javascript_result_unref (js_result);
Lisp_Object lisp_value = webkit_js_to_lisp (value);
/* Register an xwidget event here, which then runs the callback.
This ensures that the callback runs in sync with the Emacs
event loop. */
store_xwidget_js_callback_event (xw, XCDR (script_callback), lisp_value);
}
webkit_javascript_result_unref (js_result);
}

47
test/lisp/emacs-lisp/backquote-tests.el Normal file
View file

@ -0,0 +1,47 @@
;;; backquote-tests.el --- Tests for backquote.el -*- lexical-binding: t -*-
;; Copyright (C) 2019 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(require 'ert)
(ert-deftest backquote-test-basic ()
(let ((lst '(ba bb bc))
(vec [ba bb bc]))
(should (equal 3 `,(eval '(+ x y) '((x . 1) (y . 2)))))
(should (equal vec `[,@lst]))
(should (equal `(a lst c) '(a lst c)))
(should (equal `(a ,lst c) '(a (ba bb bc) c)))
(should (equal `(a ,@lst c) '(a ba bb bc c)))
;; Vectors work just like lists.
(should (equal `(a vec c) '(a vec c)))
(should (equal `(a ,vec c) '(a [ba bb bc] c)))
(should (equal `(a ,@vec c) '(a ba bb bc c)))))
(ert-deftest backquote-test-nested ()
"Test nested backquotes."
(let ((lst '(ba bb bc))
(vec [ba bb bc]))
(should (equal `(a ,`(,@lst) c) `(a ,lst c)))
(should (equal `(a ,`[,@lst] c) `(a ,vec c)))
(should (equal `(a ,@`[,@lst] c) `(a ,@lst c)))))
;;; backquote-tests.el ends here

49
test/lisp/emacs-lisp/backtrace-tests.el
View file

@ -335,6 +335,55 @@ line contains the strings \"lambda\" and \"number\"."
(should (string-match-p results
(backtrace-tests--get-substring (point-min) (point-max)))))))
(ert-deftest backtrace-tests--print-gensym ()
"Backtrace buffers can toggle `print-gensym' syntax."
(ert-with-test-buffer (:name "print-gensym")
(let* ((print-gensym nil)
(arg (list (gensym "first") (gensym) (gensym "last")))
(results (backtrace-tests--make-regexp
(backtrace-tests--result arg)))
(results-gensym (regexp-quote (let ((print-gensym t))
(backtrace-tests--result arg))))
(last-frame (backtrace-tests--make-regexp
(format (nth (1- backtrace-tests--line-count)
(backtrace-tests--backtrace-lines))
arg)))
(last-frame-gensym (regexp-quote
(let ((print-gensym t))
(format (nth (1- backtrace-tests--line-count)
(backtrace-tests--backtrace-lines))
arg)))))
(backtrace-tests--make-backtrace arg)
(backtrace-print)
(should (string-match-p results
(backtrace-tests--get-substring (point-min) (point-max))))
;; Go to the last frame.
(goto-char (point-max))
(forward-line -1)
;; Turn on print-gensym for that frame.
(backtrace-toggle-print-gensym)
(should (string-match-p last-frame-gensym
(backtrace-tests--get-substring (point) (point-max))))
;; Turn off print-gensym for the frame.
(backtrace-toggle-print-gensym)
(should (string-match-p last-frame
(backtrace-tests--get-substring (point) (point-max))))
(should (string-match-p results
(backtrace-tests--get-substring (point-min) (point-max))))
;; Turn print-gensym on for the buffer.
(backtrace-toggle-print-gensym '(4))
(should (string-match-p last-frame-gensym
(backtrace-tests--get-substring (point) (point-max))))
(should (string-match-p results-gensym
(backtrace-tests--get-substring (point-min) (point-max))))
;; Turn print-gensym off.
(backtrace-toggle-print-gensym '(4))
(should (string-match-p last-frame
(backtrace-tests--get-substring
(point) (+ (point) (length last-frame)))))
(should (string-match-p results
(backtrace-tests--get-substring (point-min) (point-max)))))))
(defun backtrace-tests--make-regexp (str)
"Make regexp from STR for `backtrace-tests--print-circle'.
Used for results of printing circular objects without

115
test/lisp/emacs-lisp/cl-print-tests.el
View file

@ -19,109 +19,17 @@
;;; Commentary:
;; See test/src/print-tests.el for tests which apply to both
;; cl-print.el and src/print.c.
;;; Code:
(require 'ert)
(cl-defstruct cl-print--test a b)
(ert-deftest cl-print-tests-1 ()
"Test cl-print code."
(let ((x (make-cl-print--test :a 1 :b 2)))
(let ((print-circle nil))
(should (equal (cl-prin1-to-string `((x . ,x) (y . ,x)))
"((x . #s(cl-print--test :a 1 :b 2)) (y . #s(cl-print--test :a 1 :b 2)))")))
(let ((print-circle t))
(should (equal (cl-prin1-to-string `((x . ,x) (y . ,x)))
"((x . #1=#s(cl-print--test :a 1 :b 2)) (y . #1#))")))
(should (string-match "\\`#f(compiled-function (x) \"[^\"]+\" [^)]*)\\'"
(cl-prin1-to-string (symbol-function #'caar))))))
(ert-deftest cl-print-tests-2 ()
(let ((x (record 'foo 1 2 3)))
(should (equal
x
(car (read-from-string (with-output-to-string (prin1 x))))))
(let ((print-circle t))
(should (string-match
"\\`(#1=#s(foo 1 2 3) #1#)\\'"
(cl-prin1-to-string (list x x)))))))
(cl-defstruct (cl-print-tests-struct
(:constructor cl-print-tests-con))
a b c d e)
(ert-deftest cl-print-tests-3 ()
"CL printing observes `print-length'."
(let ((long-list (make-list 5 'a))
(long-vec (make-vector 5 'b))
(long-struct (cl-print-tests-con))
(long-string (make-string 5 ?a))
(print-length 4))
(should (equal "(a a a a ...)" (cl-prin1-to-string long-list)))
(should (equal "[b b b b ...]" (cl-prin1-to-string long-vec)))
(should (equal "#s(cl-print-tests-struct :a nil :b nil :c nil :d nil ...)"
(cl-prin1-to-string long-struct)))
(should (equal "\"aaaa...\"" (cl-prin1-to-string long-string)))))
(ert-deftest cl-print-tests-4 ()
"CL printing observes `print-level'."
(let* ((deep-list '(a (b (c (d (e))))))
(buried-vector '(a (b (c (d [e])))))
(deep-struct (cl-print-tests-con))
(buried-struct `(a (b (c (d ,deep-struct)))))
(buried-string '(a (b (c (d #("hello" 0 5 (cl-print-test t)))))))
(buried-simple-string '(a (b (c (d "hello")))))
(print-level 4))
(setf (cl-print-tests-struct-a deep-struct) deep-list)
(should (equal "(a (b (c (d ...))))" (cl-prin1-to-string deep-list)))
(should (equal "(a (b (c (d ...))))" (cl-prin1-to-string buried-vector)))
(should (equal "(a (b (c (d ...))))" (cl-prin1-to-string buried-struct)))
(should (equal "(a (b (c (d ...))))" (cl-prin1-to-string buried-string)))
(should (equal "(a (b (c (d \"hello\"))))"
(cl-prin1-to-string buried-simple-string)))
(should (equal "#s(cl-print-tests-struct :a (a (b (c ...))) :b nil :c nil :d nil :e nil)"
(cl-prin1-to-string deep-struct)))))
(ert-deftest cl-print-tests-5 ()
"CL printing observes `print-quoted'."
(let ((quoted-stuff '('a #'b `(,c ,@d))))
(let ((print-quoted t))
(should (equal "('a #'b `(,c ,@d))"
(cl-prin1-to-string quoted-stuff))))
(let ((print-quoted nil))
(should (equal "((quote a) (function b) (\\` ((\\, c) (\\,@ d))))"
(cl-prin1-to-string quoted-stuff))))))
(ert-deftest cl-print-tests-strings ()
"CL printing prints strings and propertized strings."
(let* ((str1 "abcdefghij")
(str2 #("abcdefghij" 3 6 (bold t) 7 9 (italic t)))
(str3 #("abcdefghij" 0 10 (test t)))
(obj '(a b))
;; Since the byte compiler reuses string literals,
;; and the put-text-property call is destructive, use
;; copy-sequence to make a new string.
(str4 (copy-sequence "abcdefghij")))
(put-text-property 0 5 'test obj str4)
(put-text-property 7 10 'test obj str4)
(should (equal "\"abcdefghij\"" (cl-prin1-to-string str1)))
(should (equal "#(\"abcdefghij\" 3 6 (bold t) 7 9 (italic t))"
(cl-prin1-to-string str2)))
(should (equal "#(\"abcdefghij\" 0 10 (test t))"
(cl-prin1-to-string str3)))
(let ((print-circle nil))
(should
(equal
"#(\"abcdefghij\" 0 5 (test (a b)) 7 10 (test (a b)))"
(cl-prin1-to-string str4))))
(let ((print-circle t))
(should
(equal
"#(\"abcdefghij\" 0 5 (test #1=(a b)) 7 10 (test #1#))"
(cl-prin1-to-string str4))))))
(ert-deftest cl-print-tests-ellipsis-cons ()
"Ellipsis expansion works in conses."
(let ((print-length 4)
@ -216,23 +124,6 @@
(should (string-match expanded (with-output-to-string
(cl-print-expand-ellipsis value nil))))))
(ert-deftest cl-print-circle ()
(let ((x '(#1=(a . #1#) #1#)))
(let ((print-circle nil))
(should (string-match "\\`((a . #[0-9]) (a . #[0-9]))\\'"
(cl-prin1-to-string x))))
(let ((print-circle t))
(should (equal "(#1=(a . #1#) #1#)" (cl-prin1-to-string x))))))
(ert-deftest cl-print-circle-2 ()
;; Bug#31146.
(let ((x '(0 . #1=(0 . #1#))))
(let ((print-circle nil))
(should (string-match "\\`(0 0 . #[0-9])\\'"
(cl-prin1-to-string x))))
(let ((print-circle t))
(should (equal "(0 . #1=(0 . #1#))" (cl-prin1-to-string x))))))
(ert-deftest cl-print-tests-print-to-string-with-limit ()
(let* ((thing10 (make-list 10 'a))
(thing100 (make-list 100 'a))

21
test/lisp/net/tramp-tests.el
View file

@ -2412,9 +2412,7 @@ This checks also `file-name-as-directory', `file-name-directory',
(unwind-protect
;; FIXME: This fails on my QNAP server, see
;; /share/Web/owncloud/data/owncloud.log
(unless (and (tramp--test-nextcloud-p)
(or (not (file-remote-p source))
(not (file-remote-p target))))
(unless (tramp--test-nextcloud-p)
(make-directory source)
(should (file-directory-p source))
(write-region "foo" nil (expand-file-name "foo" source))
@ -2437,8 +2435,7 @@ This checks also `file-name-as-directory', `file-name-directory',
(unwind-protect
;; FIXME: This fails on my QNAP server, see
;; /share/Web/owncloud/data/owncloud.log
(unless
(and (tramp--test-nextcloud-p) (not (file-remote-p source)))
(unless (tramp--test-nextcloud-p)
(make-directory source)
(should (file-directory-p source))
(write-region "foo" nil (expand-file-name "foo" source))
@ -4407,7 +4404,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
"foo"
(funcall
this-shell-command-to-string
(format "echo -n ${%s:?bla}" envvar))))))
(format "echo -n ${%s:-bla}" envvar))))))
(unwind-protect
;; Set the empty value.
@ -4419,7 +4416,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
"bla"
(funcall
this-shell-command-to-string
(format "echo -n ${%s:?bla}" envvar))))
(format "echo -n ${%s:-bla}" envvar))))
;; Variable is set.
(should
(string-match
@ -4441,7 +4438,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
"foo"
(funcall
this-shell-command-to-string
(format "echo -n ${%s:?bla}" envvar))))
(format "echo -n ${%s:-bla}" envvar))))
(let ((process-environment
(cons envvar process-environment)))
;; Variable is unset.
@ -4450,12 +4447,14 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
"bla"
(funcall
this-shell-command-to-string
(format "echo -n ${%s:?bla}" envvar))))
(format "echo -n ${%s:-bla}" envvar))))
;; Variable is unset.
(should-not
(string-match
(regexp-quote envvar)
(funcall this-shell-command-to-string "env")))))))))
;; We must remove PS1, the output is truncated otherwise.
(funcall
this-shell-command-to-string "printenv | grep -v PS1")))))))))
;; This test is inspired by Bug#27009.
(ert-deftest tramp-test33-environment-variables-and-port-numbers ()
@ -5303,7 +5302,7 @@ This requires restrictions of file name syntax."
;; of process output. So we unset it temporarily.
(setenv "PS1")
(with-temp-buffer
(should (zerop (process-file "env" nil t nil)))
(should (zerop (process-file "printenv" nil t nil)))
(goto-char (point-min))
(should
(re-search-forward

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