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

merge trunk

Browse source
This commit is contained in:
Kenichi Handa 2013-06-29 12:31:15 +09:00
commit 2ed909207e
83 changed files with 2882 additions and 749 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

9
ChangeLog
View file

@ -1,3 +1,12 @@
2013-06-27 Juanma Barranquero <lekktu@gmail.com>
* Makefile.in (install-arch-indep): Do not create directories passed
with --enable-locallisppath.
2013-06-24 Glenn Morris <rgm@fencepost.gnu.org>
* configure.ac: Include X11/X.h when testing for Xft.h. (Bug#14684)
2013-06-22 Juanma Barranquero <lekktu@gmail.com>
* .bzrignore: Add GNU idutils ID database file.

16
Makefile.in
View file

@ -548,13 +548,9 @@ set_installuser=for installuser in $${LOGNAME} $${USERNAME} $${USER} \
## Note that the Makefiles in the etc directory are potentially useful
## in an installed Emacs, so should not be excluded.
## I'm not sure creating locallisppath here serves any useful purpose.
## If it has the default value, then the later write_subdir commands
## will ensure all these components exist.
## This will only do something if locallisppath has a non-standard value.
## Is it really Emacs's job to create those directories?
## Should we also be ensuring they contain subdirs.el files?
## It would be easy to do, just use write_subdir.
## We used to create locallisppath, but if it points to non-standard
## locations, is not really Emacs's job to create these directories,
## so it is no longer done.
## Note that we use tar instead of plain old cp -R/-r because the latter
## is apparently not portable (even in 2012!).
@ -564,12 +560,6 @@ set_installuser=for installuser in $${LOGNAME} $${USERNAME} $${USER} \
## See also these comments from 2004 about cp -r working fine:
## http://lists.gnu.org/archive/html/autoconf-patches/2004-11/msg00005.html
install-arch-indep: lisp leim install-info install-man ${INSTALL_ARCH_INDEP_EXTRA}
umask 022 ; \
locallisppath='${locallisppath}'; \
IFS=:; \
for d in $$locallisppath; do \
${MKDIR_P} "$(DESTDIR)$$d"; \
done
-set ${COPYDESTS} ; \
unset CDPATH; \
$(set_installuser); \

8
admin/FOR-RELEASE
View file

@ -10,6 +10,14 @@ directory in the Emacs build tree:
emacs -Q --eval "(progn (require 'info) (setq Info-directory-list '(\".\")))" \
-f info-xref-check-all
Setting Info-directory-list avoids having system info pages confuse
things. References to external manuals will be flagged as
uncheckable. You should still check these, and also that each
external manual has an appropriate redirect in the file manual/.htaccess
in the web pages repository. E.g.:
Redirect /software/emacs/manual/html_mono/automake.html /software/automake/manual/automake.html
Redirect /software/emacs/manual/html_node/automake/ /software/automake/manual/html_node/
make emacs.dvi, elisp.dvi, and deal with any errors (undefined
references etc) in the output. Break any overfull lines.
Underfull hboxes are not serious, but it can be nice to get rid of

82
admin/notes/www Normal file
View file

@ -0,0 +1,82 @@
-*- outline -*-
Copyright (C) 2013 Free Software Foundation, Inc.
See the end of the file for license conditions.
NOTES FOR EMACS WWW PAGES
* Renaming pages, redirects
Sometimes you want to move a page to a new location.
If the old location might be referenced somewhere else, you should add
some form of redirect to the new location. There are several ways to
do this:
** Use a refresh directive in the old file
https://www.gnu.org/server/standards/README.webmastering.html#htaccess
Change the entire contents of the old file to be something like:
<meta http-equiv="refresh" content="0; url=/software/emacs/manual/elisp.html">
I can't think of any reason to use this method.
** Use a .symlinks file
https://www.gnu.org/server/standards/README.webmastering.html#symlinks
This is really an interface to mod_rewrite rules, but it acts like
symlinks. Remove old-page.html altogether, and create a ".symlinks"
file in the relevant directory, with contents of the form:
# This is a comment line.
old-page.html new-page.html
Anyone visiting old-page.html will be shown the contents of new-page.html.
Note that changes to .symlinks file are only updated periodically on
the server via cron (twice an hour?). So there will be a delay (of up
to 30 minutes?) before you see your changes take effect.
This method is ok, but:
i) a person visiting old-page.html has no idea that the page has moved.
They still see old-page.html in their address bar. (In other words,
the mod_rewrite rule does not use the [R] flag.) Sometimes this is
what you want, sometimes not.
ii) it doesn't work right if the new page is in a different directory
to the old page: relative links from the visited page will break.
** Use a .htaccess file
Remove old-page.html altogether, and create a ".htaccess" file in the
relevant directory, with contents of the form:
# This is a comment line.
Redirect 301 /software/emacs/old-page.html /software/emacs/dir/new-page.html
Use "301" for a permanent redirection, otherwise you can omit the number.
Note that paths must (?) be relative to the top-level www.gnu.org.
I think this is the best method. You can specify temporary or
permanent redirects, and changes go live more-or-less straight away.
This method is useful for making cross-references to non-Emacs manuals
work; see manual/.htaccess in the repository. You only have to add a
single redirect for every given external manual, you can redirect
html_node to hmtl_node and html_mono to html_mono.
This file is part of GNU Emacs.
GNU Emacs is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
GNU Emacs is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.

3
autogen/configure vendored
View file

@ -12862,7 +12862,8 @@ fi
CFLAGS="$CFLAGS $XFT_CFLAGS"
XFT_LIBS="-lXrender $XFT_LIBS"
LIBS="$XFT_LIBS $LIBS"
ac_fn_c_check_header_mongrel "$LINENO" "X11/Xft/Xft.h" "ac_cv_header_X11_Xft_Xft_h" "$ac_includes_default"
ac_fn_c_check_header_compile "$LINENO" "X11/Xft/Xft.h" "ac_cv_header_X11_Xft_Xft_h" "#include <X11/X.h>
"
if test "x$ac_cv_header_X11_Xft_Xft_h" = x""yes; then :
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for XftFontOpen in -lXft" >&5
$as_echo_n "checking for XftFontOpen in -lXft... " >&6; }

3
configure.ac
View file

@ -2644,7 +2644,8 @@ if test "${HAVE_X11}" = "yes"; then
XFT_LIBS="-lXrender $XFT_LIBS"
LIBS="$XFT_LIBS $LIBS"
AC_CHECK_HEADER(X11/Xft/Xft.h,
AC_CHECK_LIB(Xft, XftFontOpen, HAVE_XFT=yes, , $XFT_LIBS))
AC_CHECK_LIB(Xft, XftFontOpen, HAVE_XFT=yes, , $XFT_LIBS) , ,
[[#include <X11/X.h>]])
if test "${HAVE_XFT}" = "yes"; then
AC_DEFINE(HAVE_XFT, 1, [Define to 1 if you have the Xft library.])

9
doc/emacs/files.texi
View file

@ -1267,9 +1267,12 @@ minibuffer, and displays the differences between the two files in a
buffer named @file{*diff*}. This works by running the @command{diff}
program, using options taken from the variable @code{diff-switches}.
The value of @code{diff-switches} should be a string; the default is
@code{"-c"} to specify a context diff. @xref{Top,, Diff, diff,
Comparing and Merging Files}, for more information about the
@command{diff} program.
@code{"-c"} to specify a context diff.
@c Note that the actual name of the info file is diffutils.info,
@c but it adds a dir entry for diff too.
@c On older systems, only "info diff" works, not "info diffutils".
@xref{Top,, Diff, diff, Comparing and Merging Files}, for more
information about the @command{diff} program.
The output of the @code{diff} command is shown using a major mode
called Diff mode. @xref{Diff Mode}.

1
doc/emacs/rmail.texi
View file

@ -1370,6 +1370,7 @@ mailboxes, etc. It is able to access remote mailboxes using the POP3
or IMAP4 protocol, and can retrieve mail from them using a TLS
encrypted channel. It also accepts mailbox arguments in @acronym{URL}
form. The detailed description of mailbox @acronym{URL}s can be found
@c Note this node seems to be missing in some versions of mailutils.info?
in @ref{URL,,,mailutils,Mailbox URL Formats}. In short, a
@acronym{URL} is:

17
doc/lispref/ChangeLog
View file

@ -1,3 +1,20 @@
2013-06-26 Christopher Schmidt <christopher@ch.ristopher.com>
* tips.texi (Coding Conventions): Improve wording.
2013-06-24 Glenn Morris <rgm@gnu.org>
* loading.texi (Autoload): Fix typo.
* variables.texi (Lexical Binding): Fix typo.
* functions.texi (Anonymous Functions): Put back ' removed 2012-10-23.
2013-06-23 Lars Magne Ingebrigtsen <larsi@gnus.org>
* display.texi (ImageMagick Images): Mention :max-width and
:max-height.
2013-06-20 Paul Eggert <eggert@cs.ucla.edu>
* numbers.texi (Math Functions): Remove obsolete function log10.

9
doc/lispref/display.texi
View file

@ -4653,6 +4653,15 @@ image. If only one of them is specified, the other one will be
calculated so as to preserve the aspect ratio. If both are specified,
aspect ratio may not be preserved.
@item :max-width, :max-height
The @code{:max-width} and @code{:max-height} keywords are used for
scaling if the size of the image of the image exceeds these values.
If @code{:width} is set it will have presedence over @code{max-width},
and if @code{:height} is set it will have presedence over
@code{max-height}, but you can otherwise mix these keywords as you
wish. @code{:max-width} and @code{:max-height} will always preserve
the aspec ratio.
@item :rotation
Specifies a rotation angle in degrees.

3
doc/lispref/functions.texi
View file

@ -974,10 +974,11 @@ Note that we do not quote the @code{lambda} form.
compiled. This would not happen if, say, you had constructed the
anonymous function by quoting it as a list:
@c Do not unquote this lambda!
@example
@group
(defun double-property (symbol prop)
(change-property symbol prop (lambda (x) (* 2 x))))
(change-property symbol prop '(lambda (x) (* 2 x))))
@end group
@end example

2
doc/lispref/loading.texi
View file

@ -461,7 +461,7 @@ and calls @code{define-key}; not even if the variable name is the same
symbol @var{function}.
@cindex function cell in autoload
if @var{function} already has non-void function definition that is not
If @var{function} already has a non-void function definition that is not
an autoload object, this function does nothing and returns @code{nil}.
Otherwise, it constructs an autoload object (@pxref{Autoload Type}),
and stores it as the function definition for @var{function}. The

12
doc/lispref/tips.texi
View file

@ -54,12 +54,12 @@ You should choose a short word to distinguish your program from other
Lisp programs. The names of all global symbols in your program, that
is the names of variables, constants, and functions, should begin with
that chosen prefix. Separate the prefix from the rest of the name
with a hyphen, @samp{-}. Use two hyphens if the symbol is not meant
to be used by other packages. This practice helps avoid name
conflicts, since all global variables in Emacs Lisp share the same
name space, and all functions share another name space@footnote{The
benefits of a Common Lisp-style package system are considered not to
outweigh the costs.}.
with a hyphen, @samp{-}. This practice helps avoid name conflicts,
since all global variables in Emacs Lisp share the same name space,
and all functions share another name space@footnote{The benefits of a
Common Lisp-style package system are considered not to outweigh the
costs.}. Use two hyphens to separate prefix and name if the symbol is
not meant to be used by other packages.
Occasionally, for a command name intended for users to use, it is more
convenient if some words come before the package's name prefix. And

2
doc/lispref/variables.texi
View file

@ -988,7 +988,7 @@ Here is an example:
(setq my-ticker (lambda ()
(setq x (1+ x)))))
@result{} (closure ((x . 0) t) ()
(1+ x))
(setq x (1+ x)))
(funcall my-ticker)
@result{} 1

4
doc/misc/ChangeLog
View file

@ -1,3 +1,7 @@
2013-06-24 Glenn Morris <rgm@gnu.org>
* eshell.texi: Fix cross-references to other manuals.
2013-06-23 Glenn Morris <rgm@gnu.org>
* Makefile.in (HTML_TARGETS, html, emacs-faq.html, emacs-faq):

29
doc/misc/eshell.texi
View file

@ -378,12 +378,13 @@ Similar to, but slightly different from, the GNU Coreutils
@item define
@cmindex define
Define a varalias. @xref{Variable Aliases, , , elisp}.
Define a varalias.
@xref{Variable Aliases, , , elisp, The Emacs Lisp Reference Manual}.
@item diff
@cmindex diff
Use Emacs's internal @code{diff} (not to be confused with
@code{ediff}). @xref{Comparing Files, , , elisp}.
@code{ediff}). @xref{Comparing Files, , , emacs, The GNU Emacs Manual}.
@item grep
@cmindex grep
@ -422,15 +423,18 @@ and @code{("foo" "bar")} both evaluate to @code{("foo" "bar")}.
@item locate
@cmindex locate
Alias to Emacs's @code{locate} function, which simply runs the external
@command{locate} command and parses the results. @xref{Dired and `find', , , elisp}.
@command{locate} command and parses the results.
@xref{Dired and Find, , , emacs, The GNU Emacs Manual}.
@item make
@cmindex make
Run @command{make} through @code{compile}. @xref{Running Compilations under Emacs, , , elisp}.
Run @command{make} through @code{compile}.
@xref{Compilation, , , emacs, The GNU Emacs Manual}.
@item occur
@cmindex occur
Alias to Emacs's @code{occur}. @xref{Other Search-and-Loop Commands, , , elisp}.
Alias to Emacs's @code{occur}.
@xref{Other Repeating Search, , , emacs, The GNU Emacs Manual}.
@item printnl
@cmindex printnl
@ -648,7 +652,8 @@ variables in command invocations.
@item $#var
Expands to the length of the value bound to @code{var}. Raises an error
if the value is not a sequence (@pxref{Sequences Arrays and Vectors, Sequences, , elisp}).
if the value is not a sequence
(@pxref{Sequences Arrays Vectors, Sequences, , elisp, The Emacs Lisp Reference Manual}).
@item $(lisp)
Expands to the result of evaluating the S-expression @code{(lisp)}. On
@ -680,7 +685,8 @@ any regular expression. So to split on numbers, use @samp{$var["[0-9]+" 10 20]}
@item $var[hello]
Calls @code{assoc} on @code{var} with @code{"hello"}, expecting it to be
an alist (@pxref{Association List Type, Association Lists, , elisp}).
an alist (@pxref{Association List Type, Association Lists, , elisp,
The Emacs Lisp Reference Manual}).
@item $#var[hello]
Returns the length of the cdr of the element of @code{var} who car is equal
@ -693,9 +699,11 @@ to @code{"hello"}.
Eshell's globbing syntax is very similar to that of Zsh. Users coming
from Bash can still use Bash-style globbing, as there are no
incompatibilities. Most globbing is pattern-based expansion, but there
is also predicate-based expansion. See @ref{Filename Generation, , , zsh}
is also predicate-based expansion. See
@ref{Filename Generation, , , zsh, The Z Shell Manual}
for full syntax. To customize the syntax and behaviour of globbing in
Eshell see the Customize@footnote{@xref{Customization Settings, Customize, , elisp}.}
Eshell see the Customize@footnote{@xref{Easy Customization, , , emacs,
The GNU Emacs Manual}.}
groups ``eshell-glob'' and ``eshell-pred''.
@node Input/Output
@ -757,7 +765,8 @@ can be disabled and enabled without having to unload and reload them,
and to provide a common parent Customize group for the
modules.@footnote{ERC provides a similar module facility.} An Eshell
module is defined the same as any other library but one requirement: the
module must define a Customize@footnote{@xref{Customization Settings, Customize, , elisp}.}
module must define a Customize@footnote{@xref{Customization, , ,
elisp, The Emacs Lisp Reference Manual}.}
group using @code{eshell-defgroup} (in place of @code{defgroup}) with
@code{eshell-module} as the parent group.@footnote{If the module has
no user-customizable options, then there is no need to define it as an

13
etc/ChangeLog
View file

@ -1,3 +1,16 @@
2013-06-27 Juanma Barranquero <lekktu@gmail.com>
* NEWS: Document new Desktop option `desktop-save-windows'.
2013-06-27 Stephen Berman <stephen.berman@gmx.net>
* NEWS: Mention new version of todo-mode.el and obsoleting and
renaming of old version.
2013-06-27 Juanma Barranquero <lekktu@gmail.com>
* NEWS: Mention policy change with respect to locallisppath dirs.
2013-06-18 Juanma Barranquero <lekktu@gmail.com>
* NEWS: Document new Prettify Symbols mode.

44
etc/NEWS
View file

@ -57,6 +57,9 @@ files are in share/emacs/VERSION/etc. (Emacs knows about all these
directories and will find the files in there automatically; there's no
need to set any variables due to this change.)
** Directories passed to configure option `--enable-locallisppath' are
no longer created during installation.
* Startup Changes in Emacs 24.4
@ -150,6 +153,9 @@ usually line-oriented command a visual command. Typical examples are
pager by default. See `eshell-visual-subcommands' and
`eshell-visual-options'.
** If your Emacs is compiled with libxml2 support, you can use the new
built-in web browser `eww'.
** `remember' can now store notes in separates files
You can use the new function `remember-store-in-files' within the
`remember-handler-functions' option.
@ -161,9 +167,6 @@ for new options related to this function.
** More packages look for ~/.emacs.d/<foo> additionally to ~/.<foo>.
Affected files:
~/.emacs.d/timelog replaces ~/.timelog
~/.emacs.d/todo-do replaces ~/.todo-do
~/.emacs.d/todo-done replaces ~/.todo-done
~/.emacs.d/todo-top replaces ~/.todo-top
~/.emacs.d/vip replaces ~/.vip
~/.emacs.d/viper replaces ~/.viper
~/.emacs.d/ido.last replaces ~/.ido.last
@ -177,6 +180,11 @@ Affected files:
~/.emacs.d/strokes replaces ~/.strokes
~/.emacs.d/notes replaces ~/.notes
~/.emacs.d/type-break replaces ~/.type-break
Also the following files used by the now obsolete otodo-mode.el:
~/.emacs.d/todo-do replaces ~/.todo-do
~/.emacs.d/todo-done replaces ~/.todo-done
~/.emacs.d/todo-top replaces ~/.todo-top
** Delphi mode is now called OPascal mode.
*** All delphi-* variables and functions have been renamed to opascal-*.
@ -229,6 +237,9 @@ on the given date.
*** `desktop-auto-save-timeout' defines the number of seconds between
auto-saves of the desktop.
*** `desktop-save-windows' enables saving and restoring the window/frame
configuration.
** Dired
*** New minor mode `dired-hide-details-mode' hides details.
@ -346,6 +357,25 @@ space, no spaces, or reverting to the original spacing. Like
`just-one-space' command it can handle or ignore newlines and
leave different number of spaces.
** Todo mode has been rewritten and enhanced.
New features include:
- support for multiple todo files and archive files of done items;
- renaming, reordering, moving, merging, and deleting categories;
- sortable tabular summaries of categories and the types of items they contain;
- cross-categorial lists of items filtered by specific criteria;
- more fine-grained interaction with the Emacs diary, by being able to decide
for each todo item whether it appears in the Fancy Diary display;
- highly flexible new item insertion and item editing;
- moving items between categories, storing done items in their category or in
archive files, undoing or unarchiving done items;
- reprioritizing items by inputting a numerical priority;
- extensive customizability of operation and display, including numerous faces.
To support some of these features, a new file format is used, which is
incompatible with the old format; however, you can convert old todo and done
item files to the new format on initializing the first new todo file, or at any
later time with the provided conversion command. The old version of
todo-mode.el has been made obsolete and renamed otodo-mode.el.
** Tramp
+++
@ -391,6 +421,8 @@ module.
*** terminal.el is obsolete; use term.el instead.
*** The previous version of todo-mode.el is obsolete and renamed otodo-mode.el.
*** xesam.el.
+++
@ -695,6 +727,9 @@ ImageMagick types are treated as images. The function
`imagemagick-filter-types' returns the list of types that will be
treated as images.
*** ImageMagick images now support the :max-width and :max-height
keywords.
** Minibuffer
*** In minibuffer filename prompts, `C-M-f' and `C-M-b' now move to the
@ -1188,6 +1223,9 @@ and the `attributes' slot is always nil.
The `url-retrieve' function now uses this to encode its URL argument,
in case that is not properly encoded.
*** New command `url-cookie-list' displays all the current cookies, and
allows deleting selected cookies.
** notifications.el supports now version 1.2 of the Notifications API.
The function `notifications-get-capabilities' returns the supported
server properties.

255
lisp/ChangeLog
View file

@ -15,6 +15,253 @@
(file-coding-system-alist): Use prefer-utf-8 as default for Elisp
files.
2013-06-28 Ivan Kanis <ivan@kanis.fr>
* net/shr.el (shr-render-region): New function.
* net/eww.el: Autoload `eww-browse-url'.
2013-06-27 Dmitry Gutov <dgutov@yandex.ru>
* emacs-lisp/package-x.el (package-upload-buffer-internal): Adapt
to `package-desc-version' being a list. Use
`package--ac-desc-version' to retrieve version from a package
archive element.
2013-06-27 Juanma Barranquero <lekktu@gmail.com>
New experimental feature to save&restore window and frame setup.
* desktop.el (desktop-save-windows): New defcustom.
(desktop--saved-states): New var.
(desktop--excluded-frame-parameters): New defconst.
(desktop--filter-frame-parms, desktop--find-frame-in-display)
(desktop--restore-windows, desktop--save-windows): New functions.
(desktop-save): Call `desktop--save-windows'.
(desktop-read): Call `desktop--restore-windows'.
2013-06-27 Lars Magne Ingebrigtsen <larsi@gnus.org>
* net/shr.el (add-face-text-property): Removed compat definition.
2013-06-27 Stephen Berman <stephen.berman@gmx.net>
* info.el (Info-try-follow-nearest-node): Move search for footnote
above search for node name to prevent missing a footnote (bug#14717).
2013-06-27 Stephen Berman <stephen.berman@gmx.net>
* obsolete/otodo-mode.el: Add obsolescence info to file header.
2013-06-27 Leo Liu <sdl.web@gmail.com>
* net/eww.el (eww-read-bookmarks): Check file size.
2013-06-26 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/nadvice.el (advice--defalias-fset): Move advice back to
advice--pending if newdef is nil or an autoload (bug#13820).
(advice-mapc): New function.
2013-06-26 Lars Magne Ingebrigtsen <larsi@gnus.org>
* net/eww.el (eww-mode): Undo isn't necessary in eww buffers,
probably.
(eww-mode-map): Add a menu bar.
(eww-add-bookmark): New command.
(eww-bookmark-mode): New mode and commands.
(eww-add-bookmark): Remove newlines from the title.
(eww-bookmark-browse): Don't bug out if it's the only window.
2013-06-26 Glenn Morris <rgm@gnu.org>
* htmlfontify.el (hfy-triplet): Handle unspecified-fg, bg.
(hfy-size): Handle ttys. (Bug#14668)
* info-xref.el: Update for Texinfo 5 change in *note format.
(info-xref-node-re, info-xref-note-re): New constants.
(info-xref-check-buffer): Use info-xref-note-re.
2013-06-26 Stefan Monnier <monnier@iro.umontreal.ca>
* simple.el (set-variable): Use read-from-minibuffer (bug#14710).
* emacs-lisp/package.el (package--add-to-archive-contents): Add missing
nil terminate the loop (bug#14718).
2013-06-25 Lars Magne Ingebrigtsen <larsi@gnus.org>
* net/eww.el: Rework history traversal. When going forward/back,
put these actions into the history, too, so that they can be
replayed.
(eww-render): Move the history reset to the correct buffer.
2013-06-25 Juri Linkov <juri@jurta.org>
* files-x.el (modify-dir-local-variable): Change the header comment
in the file with directory local variables. (Bug#14692)
* files-x.el (read-file-local-variable-value): Add `default'.
(Bug#14710)
2013-06-25 Lars Magne Ingebrigtsen <larsi@gnus.org>
* net/eww.el (eww-make-unique-file-name): Create a unique file
name before saving to entering `y' accidentally asynchronously.
2013-06-25 Ivan Kanis <ivan@kanis.fr>
* net/eww.el (eww-download): New command and keystroke.
2013-06-25 Lars Magne Ingebrigtsen <larsi@gnus.org>
* net/eww.el (eww-copy-page-url): Change name of command.
* net/shr.el (shr-map): Change `shr-copy-url' from `u' to `w' to
be more consistent with Info and dired.
* net/eww.el (eww-mode-map): Ditto.
2013-06-25 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/package.el: Use lexical-binding. Include obsolete
packages from archives.
(package-archive-contents): Change format; include obsolete packages.
(package-desc): Use `dir' to mark builtin packages.
(package--from-builtin): Set the `dir' field to `builtin'.
(generated-autoload-file, version-control): Declare.
(package-compute-transaction): Change first arg and return value to be
lists of package-descs. Adjust to new package-archive-contents format.
(package--add-to-archive-contents): Adjust to new
package-archive-contents format.
(package-download-transaction): Arg is now a list of package-descs.
(package-install): If `pkg' is a package name, pass it as
a requirement, so it is subject to the usual (e.g. disabled) checks.
(describe-package): Accept package-desc as well.
(describe-package-1): Describe a specific package-desc. Add links to
other package-descs for the same package name.
(package-menu-describe-package): Pass the actual package-desc.
(package-menu-mode): Add to tabulated-list-revert-hook so revert-buffer
works correctly.
(package-desc-status): New function.
(package-menu--refresh): New function, extracted
from package-menu--generate.
(package-menu--generate): Use it.
(package-delete): Update package-alist.
(package-menu-execute): Don't call package-initialize.
* progmodes/idlw-toolbar.el, progmodes/idlw-shell.el,
progmodes/idlw-help.el, progmodes/idlw-complete-structtag.el,
progmodes/ebnf-yac.el, progmodes/ebnf-otz.el, progmodes/ebnf-iso.el,
progmodes/ebnf-ebx.el, progmodes/ebnf-dtd.el, progmodes/ebnf-bnf.el,
progmodes/ebnf-abn.el, emacs-lisp/package-x.el, emacs-lisp/cl-seq.el,
emacs-lisp/cl-macs.el: Neuter the "Version:" header.
2013-06-25 Martin Rudalics <rudalics@gmx.at>
* window.el (window--state-get-1): Workaround for bug#14527.
http://lists.gnu.org/archive/html/emacs-devel/2013-06/msg00941.html
2013-06-25 Lars Magne Ingebrigtsen <larsi@gnus.org>
* net/eww.el (eww-back-url): Implement the history by stashing all
the data into a list.
(eww-forward-url): Allow going forward in the history, too.
2013-06-25 Stefan Monnier <monnier@iro.umontreal.ca>
* files-x.el (read-file-local-variable-value): Use read-from-minibuffer
for values and use read--expression for expressions (bug#14710).
(read-file-local-variable): Avoid setq.
(read-file-local-variable-mode): Use minor-mode-list.
2013-06-25 Rüdiger Sonderfeld <ruediger@c-plusplus.de>
* lisp/textmodes/bibtex.el (bibtex-generate-url-list): Add support
for DOI URLs.
2013-06-25 Rüdiger Sonderfeld <ruediger@c-plusplus.de>
* lisp/textmodes/bibtex.el (bibtex-mode, bibtex-set-dialect):
Update imenu-support when dialect changes.
2013-06-25 Leo Liu <sdl.web@gmail.com>
* ido.el (ido-read-internal): Allow forward slash on windows.
2013-06-24 Lars Magne Ingebrigtsen <larsi@gnus.org>
* net/eww.el (eww): Start of strings is \\`, not ^.
2013-06-24 Ivan Kanis <ivan@kanis.fr>
* net/shr.el (shr-browse-url): Fix interactive spec.
* net/eww.el (eww): Add a trailing slash to domain names.
2013-06-24 Juanma Barranquero <lekktu@gmail.com>
* faces.el (face-spec-recalc): Revert part of 2013-06-23T20:29:18Z!lekktu@gmail.com (bug#14705).
2013-06-24 Lars Magne Ingebrigtsen <larsi@gnus.org>
* net/shr.el (shr-browse-url): Use an external browser if given a
prefix.
* net/eww.el (eww-external-browser): Move to shr.
2013-06-24 Ivan Kanis <ivan@kanis.fr>
* net/eww.el (eww): Work more correctly for file: URLs.
(eww-detect-charset): Allow quoted charsets.
(eww-yank-page-url): New command and keystroke.
2013-06-24 Daiki Ueno <ueno@gnu.org>
* epg.el (epg-make-context): Check if PROTOCOL is valid; embed the
file name of gpg executable.
(epg-context-program): New function.
(epg-context-home-directory): New function.
(epg-context-set-program): New function.
(epg-context-set-home-directory): New function.
(epg--start): Use `epg-context-program' instead of
'epg-gpg-program'.
(epg--list-keys-1): Likewise.
2013-06-24 Leo Liu <sdl.web@gmail.com>
* ido.el (ido-read-internal): Fix bug#14620.
2013-06-23 Juanma Barranquero <lekktu@gmail.com>
* faces.el (face-documentation): Simplify.
(read-face-attribute, tty-find-type, x-resolve-font-name):
Use `string-match-p'.
(list-faces-display): Use `string-match-p'. Simplify.
(face-spec-recalc): Check face to avoid face alias loops.
(read-color): Use `string-match-p' and non-capturing parenthesis.
2013-06-23 Lars Magne Ingebrigtsen <larsi@gnus.org>
* net/shr.el (shr-rescale-image): Use the new
:max-width/:max-height functionality.
2013-06-23 Ivan Kanis <ivan@kanis.fr>
* net/eww.el (eww-search-prefix): New variable.
(eww): Use it.
(eww-external-browser): New variable.
(eww-mode-map): New keystroke.
(eww-browse-with-external-browser): New command.
* net/eww.el: Bind `C-c C-c' to "submit" in all form keymaps.
2013-06-23 Juanma Barranquero <lekktu@gmail.com>
* emacs-lisp/tabulated-list.el (tabulated-list-init-header):
Don't skip aligning the next header field when padding is 0;
otherwise, field width is not respected unless the title is as
wide as the field.
2013-06-22 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/package.el (package-el-version): Remove.
@ -48,8 +295,8 @@
2013-06-21 Dmitry Gutov <dgutov@yandex.ru>
* progmodes/ruby-mode.el (ruby-font-lock-keywords): Highlight
keyword-like methods on Kernel and Module with
* progmodes/ruby-mode.el (ruby-font-lock-keywords):
Highlight keyword-like methods on Kernel and Module with
font-lock-builtin-face.
(auto-mode-alist): Consolidate different entries into one regexp
and add more *file-s.
@ -535,8 +782,8 @@
2013-06-19 Michael Albinus <michael.albinus@gmx.de>
* net/secrets.el (secrets-struct-secret-content-type): Replace
check of introspection data by a test call of "CreateItem".
* net/secrets.el (secrets-struct-secret-content-type):
Replace check of introspection data by a test call of "CreateItem".
Some servers do not offer introspection.
2013-06-19 Stefan Monnier <monnier@iro.umontreal.ca>

4
lisp/cedet/ChangeLog
View file

@ -1,3 +1,7 @@
2013-06-25 Stefan Monnier <monnier@iro.umontreal.ca>
* data-debug.el, cedet-idutils.el: Neuter the "Version:" header.
2013-06-19 Glenn Morris <rgm@fencepost.gnu.org>
* semantic/idle.el (define-semantic-idle-service):

2
lisp/cedet/cedet-idutils.el
View file

@ -3,7 +3,7 @@
;; Copyright (C) 2009-2013 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
;; Version: 0.2
;; Old-Version: 0.2
;; Keywords: OO, lisp
;; Package: cedet

2
lisp/cedet/data-debug.el
View file

@ -3,7 +3,7 @@
;; Copyright (C) 2007-2013 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Version: 0.2
;; Old-Version: 0.2
;; Keywords: OO, lisp
;; Package: cedet

80
lisp/desktop.el
View file

@ -371,6 +371,12 @@ modes are restored automatically; they should not be listed here."
:type '(repeat symbol)
:group 'desktop)
(defcustom desktop-save-windows nil
"When non-nil, save window/frame configuration to desktop file."
:type 'boolean
:group 'desktop
:version "24.4")
(defcustom desktop-file-name-format 'absolute
"Format in which desktop file names should be saved.
Possible values are:
@ -556,6 +562,9 @@ DIRNAME omitted or nil means use `desktop-dirname'."
"Checksum of the last auto-saved contents of the desktop file.
Used to avoid writing contents unchanged between auto-saves.")
(defvar desktop--saved-states nil
"Internal use only.")
;; ----------------------------------------------------------------------------
;; Desktop file conflict detection
(defvar desktop-file-modtime nil
@ -858,6 +867,42 @@ DIRNAME must be the directory in which the desktop file will be saved."
;; ----------------------------------------------------------------------------
(defconst desktop--excluded-frame-parameters
'(buffer-list
buffer-predicate
buried-buffer-list
explicit-name
font-backend
minibuffer
name
outer-window-id
parent-id
window-id
window-system)
"Frame parameters not saved or restored.")
(defun desktop--filter-frame-parms (frame)
"Return frame parameters of FRAME.
Parameters in `desktop--excluded-frame-parameters' are excluded.
Internal use only."
(let (params)
(dolist (param (frame-parameters frame))
(unless (memq (car param) desktop--excluded-frame-parameters)
(push param params)))
params))
(defun desktop--save-windows ()
"Save window/frame state, as a global variable.
Intended to be called from `desktop-save'.
Internal use only."
(setq desktop--saved-states
(and desktop-save-windows
(mapcar (lambda (frame)
(cons (desktop--filter-frame-parms frame)
(window-state-get (frame-root-window frame) t)))
(frame-list))))
(desktop-outvar 'desktop--saved-states))
;;;###autoload
(defun desktop-save (dirname &optional release auto-save)
"Save the desktop in a desktop file.
@ -896,6 +941,9 @@ and don't save the buffer if they are the same."
(save-excursion (run-hooks 'desktop-save-hook))
(goto-char (point-max))
(insert "\n;; Global section:\n")
;; Called here because we save the window/frame state as a global
;; variable for compatibility with previous Emacsen.
(desktop--save-windows)
(mapc (function desktop-outvar) desktop-globals-to-save)
(when (memq 'kill-ring desktop-globals-to-save)
(insert
@ -954,6 +1002,37 @@ This function also sets `desktop-dirname' to nil."
(defvar desktop-lazy-timer nil)
;; ----------------------------------------------------------------------------
(defun desktop--find-frame-in-display (frames display)
(let (result)
(while (and frames (not result))
(if (equal display (frame-parameter (car frames) 'display))
(setq result (car frames))
(setq frames (cdr frames))))
result))
(defun desktop--restore-windows ()
"Restore window/frame configuration.
Internal use only."
(when (and desktop-save-windows desktop--saved-states)
(condition-case nil
(let ((frames (frame-list)))
(dolist (state desktop--saved-states)
(let* ((fconfig (car state))
(display (cdr (assq 'display fconfig)))
(frame (desktop--find-frame-in-display frames display)))
(if (not frame)
;; no frames in the display -- make a new one
(setq frame (make-frame-on-display display fconfig))
;; found one -- reuse and remove from list
(setq frames (delq frame frames))
(modify-frame-parameters frame fconfig))
;; restore windows
(window-state-put (cdr state) (frame-root-window frame) 'safe)))
;; delete any remaining frames
(mapc #'delete-frame frames))
(error
(message "Error loading window configuration from desktop file")))))
;;;###autoload
(defun desktop-read (&optional dirname)
"Read and process the desktop file in directory DIRNAME.
@ -1022,6 +1101,7 @@ Using it may cause conflicts. Use it anyway? " owner)))))
(switch-to-buffer (car (buffer-list)))
(run-hooks 'desktop-delay-hook)
(setq desktop-delay-hook nil)
(desktop--restore-windows)
(run-hooks 'desktop-after-read-hook)
(message "Desktop: %d buffer%s restored%s%s."
desktop-buffer-ok-count

2
lisp/emacs-lisp/cl-macs.el
View file

@ -3,7 +3,7 @@
;; Copyright (C) 1993, 2001-2013 Free Software Foundation, Inc.
;; Author: Dave Gillespie <daveg@synaptics.com>
;; Version: 2.02
;; Old-Version: 2.02
;; Keywords: extensions
;; Package: emacs

2
lisp/emacs-lisp/cl-seq.el
View file

@ -3,7 +3,7 @@
;; Copyright (C) 1993, 2001-2013 Free Software Foundation, Inc.
;; Author: Dave Gillespie <daveg@synaptics.com>
;; Version: 2.02
;; Old-Version: 2.02
;; Keywords: extensions
;; Package: emacs

78
lisp/emacs-lisp/nadvice.el
View file

@ -313,8 +313,7 @@ of the piece of advice."
(when (get symbol 'advice--saved-rewrite)
(put symbol 'advice--saved-rewrite nil))
(setq newdef (advice--normalize symbol newdef))
(let* ((olddef (advice--strip-macro
(if (fboundp symbol) (symbol-function symbol))))
(let* ((olddef (advice--strip-macro (symbol-function symbol)))
(oldadv
(cond
((null (get symbol 'advice--pending))
@ -324,15 +323,18 @@ of the piece of advice."
symbol)
nil)))
((or (not olddef) (autoloadp olddef))
(prog1 (get symbol 'advice--pending)
(put symbol 'advice--pending nil)))
(get symbol 'advice--pending))
(t (message "Dropping left-over advice--pending for %s" symbol)
(put symbol 'advice--pending nil)
olddef))))
(let* ((snewdef (advice--strip-macro newdef))
(snewadv (advice--subst-main oldadv snewdef)))
(funcall (or fsetfun #'fset) symbol
(if (eq snewdef newdef) snewadv (cons 'macro snewadv))))))
(if (and newdef (not (autoloadp newdef)))
(let* ((snewdef (advice--strip-macro newdef))
(snewadv (advice--subst-main oldadv snewdef)))
(put symbol 'advice--pending nil)
(funcall (or fsetfun #'fset) symbol
(if (eq snewdef newdef) snewadv (cons 'macro snewadv))))
(unless (eq oldadv (get symbol 'advice--pending))
(put symbol 'advice--pending (advice--subst-main oldadv nil)))
(funcall (or fsetfun #'fset) symbol newdef))))
;;;###autoload
@ -345,7 +347,7 @@ is defined as a macro, alias, command, ..."
;; - change all defadvice in lisp/**/*.el.
;; - rewrite advice.el on top of this.
;; - obsolete advice.el.
(let* ((f (and (fboundp symbol) (symbol-function symbol)))
(let* ((f (symbol-function symbol))
(nf (advice--normalize symbol f)))
(unless (eq f nf) ;; Most importantly, if nf == nil!
(fset symbol nf))
@ -370,37 +372,34 @@ is defined as a macro, alias, command, ..."
;;;###autoload
(defun advice-remove (symbol function)
"Like `remove-function' but for the function named SYMBOL.
Contrary to `remove-function', this will work also when SYMBOL is a macro
and it will not signal an error if SYMBOL is not `fboundp'.
Contrary to `remove-function', this also works when SYMBOL is a macro
or an autoload and it preserves `fboundp'.
Instead of the actual function to remove, FUNCTION can also be the `name'
of the piece of advice."
(when (fboundp symbol)
(let ((f (symbol-function symbol)))
;; Can't use the `if' place here, because the body is too large,
;; resulting in use of code that only works with lexical-scoping.
(remove-function (if (eq (car-safe f) 'macro)
(cdr f)
(symbol-function symbol))
function)
(unless (advice--p
(if (eq (car-safe f) 'macro) (cdr f) (symbol-function symbol)))
;; Not advised any more.
(remove-function (get symbol 'defalias-fset-function)
#'advice--defalias-fset)
(if (eq (symbol-function symbol)
(cdr (get symbol 'advice--saved-rewrite)))
(fset symbol (car (get symbol 'advice--saved-rewrite))))))
nil))
(let ((f (symbol-function symbol)))
;; Can't use the `if' place here, because the body is too large,
;; resulting in use of code that only works with lexical-scoping.
(remove-function (if (eq (car-safe f) 'macro)
(cdr f)
(symbol-function symbol))
function)
(unless (advice--p
(if (eq (car-safe f) 'macro) (cdr f) (symbol-function symbol)))
;; Not advised any more.
(remove-function (get symbol 'defalias-fset-function)
#'advice--defalias-fset)
(if (eq (symbol-function symbol)
(cdr (get symbol 'advice--saved-rewrite)))
(fset symbol (car (get symbol 'advice--saved-rewrite))))))
nil)
;; (defun advice-mapc (fun symbol)
;; "Apply FUN to every function added as advice to SYMBOL.
;; FUN is called with a two arguments: the function that was added, and the
;; properties alist that was specified when it was added."
;; (let ((def (or (get symbol 'advice--pending)
;; (if (fboundp symbol) (symbol-function symbol)))))
;; (while (advice--p def)
;; (funcall fun (advice--car def) (advice--props def))
;; (setq def (advice--cdr def)))))
(defun advice-mapc (fun def)
"Apply FUN to every advice function in DEF.
FUN is called with a two arguments: the function that was added, and the
properties alist that was specified when it was added."
(while (advice--p def)
(funcall fun (advice--car def) (advice--props def))
(setq def (advice--cdr def))))
;;;###autoload
(defun advice-member-p (advice function-name)
@ -410,8 +409,7 @@ of the piece of advice."
(advice--member-p advice advice
(or (get function-name 'advice--pending)
(advice--strip-macro
(if (fboundp function-name)
(symbol-function function-name))))))
(symbol-function function-name)))))
;; When code is advised, called-interactively-p needs to be taught to skip
;; the advising frames.

7
lisp/emacs-lisp/package-x.el
View file

@ -4,7 +4,6 @@
;; Author: Tom Tromey <tromey@redhat.com>
;; Created: 10 Mar 2007
;; Version: 0.9
;; Keywords: tools
;; Package: package
@ -205,12 +204,12 @@ if it exists."
package--default-summary)
(read-string "Description of package: ")
(package-desc-summary pkg-desc)))
(pkg-version (package-desc-version pkg-desc))
(split-version (package-desc-version pkg-desc))
(commentary
(pcase file-type
(`single (lm-commentary))
(`tar nil))) ;; FIXME: Get it from the README file.
(split-version (version-to-list pkg-version))
(pkg-version (package-version-join split-version))
(pkg-buffer (current-buffer)))
;; Get archive-contents from ARCHIVE-URL if it's non-nil, or
@ -224,7 +223,7 @@ if it exists."
(let ((elt (assq pkg-name (cdr contents))))
(if elt
(if (version-list-<= split-version
(package-desc-version (cdr elt)))
(package--ac-desc-version (cdr elt)))
(error "New package has smaller version: %s" pkg-version)
(setcdr elt new-desc))
(setq contents (cons (car contents)

445
lisp/emacs-lisp/package.el
View file

@ -1,8 +1,9 @@
;;; package.el --- Simple package system for Emacs
;;; package.el --- Simple package system for Emacs -*- lexical-binding:t -*-
;; Copyright (C) 2007-2013 Free Software Foundation, Inc.
;; Author: Tom Tromey <tromey@redhat.com>
;; Daniel Hackney <dan@haxney.org>
;; Created: 10 Mar 2007
;; Version: 1.0.1
;; Keywords: tools
@ -253,7 +254,7 @@ Lower version numbers than this will probably be understood as well.")
(defvar package-archive-contents nil
"Cache of the contents of the Emacs Lisp Package Archive.
This is an alist mapping package names (symbols) to
`package-desc' structures.")
non-empty lists of `package-desc' structures.")
(put 'package-archive-contents 'risky-local-variable t)
(defcustom package-user-dir (locate-user-emacs-file "elpa")
@ -306,27 +307,27 @@ contrast, `package-user-dir' contains packages for personal use."
(nth 1 requirements)
requirements))))))
"Structure containing information about an individual package.
Slots:
`name' Name of the package, as a symbol.
`name' Name of the package, as a symbol.
`version' Version of the package, as a version list.
`summary' Short description of the package, typically taken from
the first line of the file.
the first line of the file.
`reqs' Requirements of the package. A list of (PACKAGE
VERSION-LIST) naming the dependent package and the minimum
required version.
`reqs' Requirements of the package. A list of (PACKAGE
VERSION-LIST) naming the dependent package and the minimum
required version.
`kind' The distribution format of the package. Currently, it is
either `single' or `tar'.
`kind' The distribution format of the package. Currently, it is
either `single' or `tar'.
`archive' The name of the archive (as a string) whence this
package came.
package came.
`dir' The directory where the package is installed (if installed)."
`dir' The directory where the package is installed (if installed),
`builtin' if it is built-in, or nil otherwise."
name
version
(summary package--default-summary)
@ -488,7 +489,8 @@ specifying the minimum acceptable version."
(defun package--from-builtin (bi-desc)
(package-desc-create :name (pop bi-desc)
:version (package--bi-desc-version bi-desc)
:summary (package--bi-desc-summary bi-desc)))
:summary (package--bi-desc-summary bi-desc)
:dir 'builtin))
;; This function goes ahead and activates a newer version of a package
;; if an older one was already activated. This is not ideal; we'd at
@ -583,6 +585,9 @@ EXTRA-PROPERTIES is currently unused."
nil file))
file)
(defvar generated-autoload-file)
(defvar version-control)
(defun package-generate-autoloads (name pkg-dir)
(require 'autoload) ;Load before we let-bind generated-autoload-file!
(let* ((auto-name (format "%s-autoloads.el" name))
@ -756,9 +761,9 @@ MIN-VERSION should be a version list."
;; Also check built-in packages.
(package-built-in-p package min-version)))
(defun package-compute-transaction (package-list requirements)
"Return a list of packages to be installed, including PACKAGE-LIST.
PACKAGE-LIST should be a list of package names (symbols).
(defun package-compute-transaction (packages requirements)
"Return a list of packages to be installed, including PACKAGES.
PACKAGES should be a list of `package-desc'.
REQUIREMENTS should be a list of additional requirements; each
element in this list should have the form (PACKAGE VERSION-LIST),
@ -769,40 +774,65 @@ This function recursively computes the requirements of the
packages in REQUIREMENTS, and returns a list of all the packages
that must be installed. Packages that are already installed are
not included in this list."
;; FIXME: We really should use backtracking to explore the whole
;; search space (e.g. if foo require bar-1.3, and bar-1.4 requires toto-1.1
;; whereas bar-1.3 requires toto-1.0 and the user has put a hold on toto-1.0:
;; the current code might fail to see that it could install foo by using the
;; older bar-1.3).
(dolist (elt requirements)
(let* ((next-pkg (car elt))
(next-version (cadr elt)))
(unless (package-installed-p next-pkg next-version)
(next-version (cadr elt))
(already ()))
(dolist (pkg packages)
(if (eq next-pkg (package-desc-name pkg))
(setq already pkg)))
(cond
(already
(if (version-list-< next-version (package-desc-version already))
;; Move to front, so it gets installed early enough (bug#14082).
(setq packages (cons already (delq already packages)))
(error "Need package `%s-%s', but only %s is available"
next-pkg (package-version-join next-version)
(package-version-join (package-desc-version already)))))
((package-installed-p next-pkg next-version) nil)
(t
;; A package is required, but not installed. It might also be
;; blocked via `package-load-list'.
(let ((pkg-desc (cdr (assq next-pkg package-archive-contents)))
;; FIXME: package-disabled-p needs to use a <= test!
(disabled (package-disabled-p next-pkg next-version)))
(when disabled
(if (stringp disabled)
(error "Package `%s' held at version %s, \
(let ((pkg-descs (cdr (assq next-pkg package-archive-contents)))
(found nil)
(problem nil))
(while (and pkg-descs (not found))
(let* ((pkg-desc (pop pkg-descs))
(version (package-desc-version pkg-desc))
(disabled (package-disabled-p next-pkg version)))
(cond
((version-list-< version next-version)
(error
"Need package `%s-%s', but only %s is available"
next-pkg (package-version-join next-version)
(package-version-join version)))
(disabled
(unless problem
(setq problem
(if (stringp disabled)
(format "Package `%s' held at version %s, \
but version %s required"
(symbol-name next-pkg) disabled
(package-version-join next-version))
(error "Required package '%s' is disabled"
(symbol-name next-pkg))))
(unless pkg-desc
(error "Package `%s-%s' is unavailable"
(symbol-name next-pkg)
(package-version-join next-version)))
(unless (version-list-<= next-version
(package-desc-version pkg-desc))
(error
"Need package `%s-%s', but only %s is available"
(symbol-name next-pkg) (package-version-join next-version)
(package-version-join (package-desc-version pkg-desc))))
;; Move to front, so it gets installed early enough (bug#14082).
(setq package-list (cons next-pkg (delq next-pkg package-list)))
(setq package-list
(package-compute-transaction package-list
(package-desc-reqs
pkg-desc)))))))
package-list)
next-pkg disabled
(package-version-join next-version))
(format "Required package '%s' is disabled"
next-pkg)))))
(t (setq found pkg-desc)))))
(unless found
(if problem
(error problem)
(error "Package `%s-%s' is unavailable"
next-pkg (package-version-join next-version))))
(setq packages
(package-compute-transaction (cons found packages)
(package-desc-reqs found))))))))
packages)
(defun package-read-from-string (str)
"Read a Lisp expression from STR.
@ -875,40 +905,36 @@ Also, add the originating archive to the `package-desc' structure."
:summary (package--ac-desc-summary (cdr package))
:kind (package--ac-desc-kind (cdr package))
:archive archive))
(entry (cons name pkg-desc))
(existing-package (assq name package-archive-contents))
(existing-packages (assq name package-archive-contents))
(pinned-to-archive (assoc name package-pinned-packages)))
(cond
;; Skip entirely if pinned to another archive or if no more recent
;; than what we already have installed.
;; Skip entirely if pinned to another archive or already installed.
((or (and pinned-to-archive
(not (equal (cdr pinned-to-archive) archive)))
(let ((bi (assq name package--builtin-versions)))
(and bi (version-list-<= version (cdr bi))))
(and bi (version-list-= version (cdr bi))))
(let ((ins (cdr (assq name package-alist))))
(and ins (version-list-<= version
(package-desc-version (car ins))))))
(and ins (version-list-= version
(package-desc-version (car ins))))))
nil)
((not existing-package)
(push entry package-archive-contents))
((version-list-< (package-desc-version (cdr existing-package))
version)
;; Replace the entry with this one.
(setq package-archive-contents
(cons entry
(delq existing-package
package-archive-contents)))))))
((not existing-packages)
(push (list name pkg-desc) package-archive-contents))
(t
(while
(if (and (cdr existing-packages)
(version-list-<
version (package-desc-version (cadr existing-packages))))
(setq existing-packages (cdr existing-packages))
(push pkg-desc (cdr existing-packages))
nil))))))
(defun package-download-transaction (package-list)
"Download and install all the packages in PACKAGE-LIST.
PACKAGE-LIST should be a list of package names (symbols).
(defun package-download-transaction (packages)
"Download and install all the packages in PACKAGES.
PACKAGES should be a list of package-desc.
This function assumes that all package requirements in
PACKAGE-LIST are satisfied, i.e. that PACKAGE-LIST is computed
PACKAGES are satisfied, i.e. that PACKAGES is computed
using `package-compute-transaction'."
;; FIXME: make package-list a list of pkg-desc.
(dolist (elt package-list)
(let ((desc (cdr (assq elt package-archive-contents))))
(package-install-from-archive desc))))
(mapc #'package-install-from-archive packages))
;;;###autoload
(defun package-install (pkg)
@ -924,21 +950,16 @@ in an archive in `package-archives'. Interactively, prompt for its name."
(unless package-archive-contents
(package-refresh-contents))
(list (intern (completing-read
"Install package: "
(mapcar (lambda (elt)
(cons (symbol-name (car elt))
nil))
package-archive-contents)
"Install package: "
(mapcar (lambda (elt) (symbol-name (car elt)))
package-archive-contents)
nil t)))))
(let ((pkg-desc
(if (package-desc-p pkg) pkg
(cdr (assq pkg package-archive-contents)))))
(unless pkg-desc
(error "Package `%s' is not available for installation" pkg))
(package-download-transaction
;; FIXME: Use (list pkg-desc) instead of just the name.
(package-compute-transaction (list (package-desc-name pkg-desc))
(package-desc-reqs pkg-desc)))))
(if (package-desc-p pkg)
(package-compute-transaction (list pkg)
(package-desc-reqs pkg))
(package-compute-transaction ()
(list (list pkg))))))
(defun package-strip-rcs-id (str)
"Strip RCS version ID from the version string STR.
@ -1043,15 +1064,17 @@ The file can either be a tar file or an Emacs Lisp file."
(defun package-delete (pkg-desc)
(let ((dir (package-desc-dir pkg-desc)))
(if (string-equal (file-name-directory dir)
(file-name-as-directory
(expand-file-name package-user-dir)))
(progn
(delete-directory dir t t)
(message "Package `%s' deleted." (package-desc-full-name pkg-desc)))
;; Don't delete "system" packages
(error "Package `%s' is a system package, not deleting"
(package-desc-full-name pkg-desc)))))
(if (not (string-prefix-p (file-name-as-directory
(expand-file-name package-user-dir))
(expand-file-name dir)))
;; Don't delete "system" packages.
(error "Package `%s' is a system package, not deleting"
(package-desc-full-name pkg-desc))
(delete-directory dir t t)
;; Update package-alist.
(let* ((name (package-desc-name pkg-desc)))
(delete pkg-desc (assq name package-alist)))
(message "Package `%s' deleted." (package-desc-full-name pkg-desc)))))
(defun package-archive-base (desc)
"Return the archive containing the package NAME."
@ -1110,26 +1133,25 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages."
(defun describe-package (package)
"Display the full documentation of PACKAGE (a symbol)."
(interactive
(let* ((guess (function-called-at-point))
packages val)
(let* ((guess (function-called-at-point)))
(require 'finder-inf nil t)
;; Load the package list if necessary (but don't activate them).
(unless package--initialized
(package-initialize t))
(setq packages (append (mapcar 'car package-alist)
(mapcar 'car package-archive-contents)
(mapcar 'car package--builtins)))
(unless (memq guess packages)
(setq guess nil))
(setq packages (mapcar 'symbol-name packages))
(setq val
(completing-read (if guess
(format "Describe package (default %s): "
guess)
"Describe package: ")
packages nil t nil nil guess))
(list (if (equal val "") guess (intern val)))))
(if (not (and package (symbolp package)))
(let ((packages (append (mapcar 'car package-alist)
(mapcar 'car package-archive-contents)
(mapcar 'car package--builtins))))
(unless (memq guess packages)
(setq guess nil))
(setq packages (mapcar 'symbol-name packages))
(let ((val
(completing-read (if guess
(format "Describe package (default %s): "
guess)
"Describe package: ")
packages nil t nil nil guess)))
(list (intern val))))))
(if (not (or (package-desc-p package) (and package (symbolp package))))
(message "No package specified")
(help-setup-xref (list #'describe-package package)
(called-interactively-p 'interactive))
@ -1137,57 +1159,52 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages."
(with-current-buffer standard-output
(describe-package-1 package)))))
(defun describe-package-1 (package)
(defun describe-package-1 (pkg)
(require 'lisp-mnt)
(let ((package-name (symbol-name package))
(built-in (assq package package--builtins))
desc pkg-dir reqs version installable archive)
(prin1 package)
(let* ((desc (or
(if (package-desc-p pkg) pkg)
(cadr (assq pkg package-alist))
(let ((built-in (assq pkg package--builtins)))
(if built-in
(package--from-builtin built-in)
(cadr (assq pkg package-archive-contents))))))
(name (if desc (package-desc-name desc) pkg))
(pkg-dir (if desc (package-desc-dir desc)))
(reqs (if desc (package-desc-reqs desc)))
(version (if desc (package-desc-version desc)))
(archive (if desc (package-desc-archive desc)))
(built-in (eq pkg-dir 'builtin))
(installable (and archive (not built-in)))
(status (if desc (package-desc-status desc) "orphan")))
(prin1 name)
(princ " is ")
(cond
;; Loaded packages are in `package-alist'.
((setq desc (cadr (assq package package-alist)))
(setq version (package-version-join (package-desc-version desc)))
(if (setq pkg-dir (package-desc-dir desc))
(insert "an installed package.\n\n")
;; This normally does not happen.
(insert "a deleted package.\n\n")))
;; Available packages are in `package-archive-contents'.
((setq desc (cdr (assq package package-archive-contents)))
(setq version (package-version-join (package-desc-version desc))
archive (package-desc-archive desc)
installable t)
(if built-in
(insert "a built-in package.\n\n")
(insert "an uninstalled package.\n\n")))
(built-in
(setq desc (package--from-builtin built-in)
version (package-version-join (package-desc-version desc)))
(insert "a built-in package.\n\n"))
(t
(insert "an orphan package.\n\n")))
(princ (if (memq (aref status 0) '(?a ?e ?i ?o ?u)) "an " "a "))
(princ status)
(princ " package.\n\n")
(insert " " (propertize "Status" 'font-lock-face 'bold) ": ")
(cond (pkg-dir
(insert (propertize "Installed"
(cond (built-in
(insert (propertize (capitalize status)
'font-lock-face 'font-lock-builtin-face)
"."))
(pkg-dir
(insert (propertize (capitalize status) ;FIXME: Why comment-face?
'font-lock-face 'font-lock-comment-face))
(insert " in `")
;; Todo: Add button for uninstalling.
(help-insert-xref-button (file-name-as-directory pkg-dir)
(help-insert-xref-button (abbreviate-file-name
(file-name-as-directory pkg-dir))
'help-package-def pkg-dir)
(if built-in
(if (and (package-built-in-p name)
(not (package-built-in-p name version)))
(insert "',\n shadowing a "
(propertize "built-in package"
'font-lock-face 'font-lock-builtin-face)
".")
(insert "'.")))
(installable
(if built-in
(insert (propertize "Built-in."
'font-lock-face 'font-lock-builtin-face)
" Alternate version available")
(insert "Available"))
(insert " from " archive)
(insert (capitalize status))
(insert " from " (format "%s" archive))
(insert " -- ")
(let ((button-text (if (display-graphic-p) "Install" "[Install]"))
(button-face (if (display-graphic-p)
@ -1198,14 +1215,12 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages."
(insert-text-button button-text 'face button-face 'follow-link t
'package-desc desc
'action 'package-install-button-action)))
(built-in
(insert (propertize "Built-in."
'font-lock-face 'font-lock-builtin-face)))
(t (insert "Deleted.")))
(t (insert (capitalize status) ".")))
(insert "\n")
(and version (> (length version) 0)
(and version
(insert " "
(propertize "Version" 'font-lock-face 'bold) ": " version "\n"))
(propertize "Version" 'font-lock-face 'bold) ": "
(package-version-join version) "\n"))
(setq reqs (if desc (package-desc-reqs desc)))
(when reqs
@ -1225,11 +1240,38 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages."
(help-insert-xref-button text 'help-package name))
(insert "\n")))
(insert " " (propertize "Summary" 'font-lock-face 'bold)
": " (if desc (package-desc-summary desc)) "\n\n")
": " (if desc (package-desc-summary desc)) "\n")
(let* ((all-pkgs (append (cdr (assq name package-alist))
(cdr (assq name package-archive-contents))
(let ((bi (assq name package--builtins)))
(if bi (list (package--from-builtin bi))))))
(other-pkgs (delete desc all-pkgs)))
(when other-pkgs
(insert " " (propertize "Other versions" 'font-lock-face 'bold) ": "
(mapconcat
(lambda (opkg)
(let* ((ov (package-desc-version opkg))
(dir (package-desc-dir opkg))
(from (or (package-desc-archive opkg)
(if (stringp dir) "installed" dir))))
(if (not ov) (format "%s" from)
(format "%s (%s)"
(make-text-button (package-version-join ov) nil
'face 'link
'follow-link t
'action
(lambda (_button)
(describe-package opkg)))
from))))
other-pkgs ", ")
".\n")))
(insert "\n")
(if built-in
;; For built-in packages, insert the commentary.
(let ((fn (locate-file (concat package-name ".el") load-path
(let ((fn (locate-file (format "%s.el" name) load-path
load-file-rep-suffixes))
(opoint (point)))
(insert (or (lm-commentary fn) ""))
@ -1239,14 +1281,15 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages."
(replace-match ""))
(while (re-search-forward "^\\(;+ ?\\)" nil t)
(replace-match ""))))
(let ((readme (expand-file-name (concat package-name "-readme.txt")
(let ((readme (expand-file-name (format "%s-readme.txt" name)
package-user-dir))
readme-string)
;; For elpa packages, try downloading the commentary. If that
;; fails, try an existing readme file in `package-user-dir'.
(cond ((condition-case nil
(package--with-work-buffer (package-archive-base desc)
(concat package-name "-readme.txt")
(package--with-work-buffer
(package-archive-base desc)
(format "%s-readme.txt" name)
(setq buffer-file-name
(expand-file-name readme package-user-dir))
(let ((version-control 'never))
@ -1350,6 +1393,7 @@ Letters do not insert themselves; instead, they are commands.
("Description" 0 nil)])
(setq tabulated-list-padding 2)
(setq tabulated-list-sort-key (cons "Status" nil))
(add-hook 'tabulated-list-revert-hook 'package-menu--refresh)
(tabulated-list-init-header))
(defmacro package--push (pkg-desc status listname)
@ -1363,34 +1407,49 @@ package PKG-DESC, add one. The alist is keyed with PKG-DESC."
(defvar package-list-unversioned nil
"If non-nil include packages that don't have a version in `list-package'.")
(defun package-menu--generate (remember-pos packages)
"Populate the Package Menu.
If REMEMBER-POS is non-nil, keep point on the same entry.
PACKAGES should be t, which means to display all known packages,
or a list of package names (symbols) to display."
(defun package-desc-status (pkg-desc)
(let* ((name (package-desc-name pkg-desc))
(dir (package-desc-dir pkg-desc))
(lle (assq name package-load-list))
(held (cadr lle))
(version (package-desc-version pkg-desc)))
(cond
((eq dir 'builtin) "built-in")
((and lle (null held)) "disabled")
((stringp held)
(let ((hv (if (stringp held) (version-to-list held))))
(cond
((version-list-= version hv) "held")
((version-list-< version hv) "obsolete")
(t "disabled"))))
((package-built-in-p name version) "obsolete")
(dir ;One of the installed packages.
(cond
((not (file-exists-p (package-desc-dir pkg-desc))) "deleted")
((eq pkg-desc (cadr (assq name package-alist))) "installed")
(t "obsolete")))
(t
(let* ((ins (cadr (assq name package-alist)))
(ins-v (if ins (package-desc-version ins))))
(cond
((or (null ins) (version-list-< ins-v version))
(if (memq name package-menu--new-package-list)
"new" "available"))
((version-list-< version ins-v) "obsolete")
((version-list-= version ins-v) "installed")))))))
(defun package-menu--refresh (&optional packages)
"Re-populate the `tabulated-list-entries'.
PACKAGES should be nil or t, which means to display all known packages."
;; Construct list of (PKG-DESC . STATUS).
(unless packages (setq packages t))
(let (info-list name)
;; Installed packages:
(dolist (elt package-alist)
(setq name (car elt))
(when (or (eq packages t) (memq name packages))
(let* ((lle (assq name package-load-list))
(held (cadr lle))
(hv (if (stringp held) (version-to-list held))))
(dolist (pkg (cdr elt))
(let ((version (package-desc-version pkg)))
(package--push pkg
(cond
((and lle (null held)) "disabled")
(hv
(cond
((version-list-= version hv) "held")
((version-list-< version hv) "obsolete")
(t "disabled")))
((package-built-in-p name version) "obsolete")
((eq pkg (cadr elt)) "installed")
(t "obsolete"))
info-list))))))
(dolist (pkg (cdr elt))
(package--push pkg (package-desc-status pkg) info-list))))
;; Built-in packages:
(dolist (elt package--builtins)
@ -1405,17 +1464,23 @@ or a list of package names (symbols) to display."
(dolist (elt package-archive-contents)
(setq name (car elt))
(when (or (eq packages t) (memq name packages))
(let ((hold (assq name package-load-list)))
(package--push (cdr elt)
(cond
((and hold (null (cadr hold))) "disabled")
((memq name package-menu--new-package-list) "new")
(t "available"))
info-list))))
(dolist (pkg (cdr elt))
;; Hide obsolete packages.
(unless (package-installed-p (package-desc-name pkg)
(package-desc-version pkg))
(package--push pkg (package-desc-status pkg) info-list)))))
;; Print the result.
(setq tabulated-list-entries (mapcar 'package-menu--print-info info-list))
(tabulated-list-print remember-pos)))
(setq tabulated-list-entries
(mapcar #'package-menu--print-info info-list))))
(defun package-menu--generate (remember-pos packages)
"Populate the Package Menu.
If REMEMBER-POS is non-nil, keep point on the same entry.
PACKAGES should be t, which means to display all known packages,
or a list of package names (symbols) to display."
(package-menu--refresh packages)
(tabulated-list-print remember-pos))
(defun package-menu--print-info (pkg)
"Return a package entry suitable for `tabulated-list-entries'.
@ -1461,8 +1526,8 @@ If optional arg BUTTON is non-nil, describe its associated package."
(let ((pkg-desc (if button (button-get button 'package-desc)
(tabulated-list-get-id))))
(if pkg-desc
;; FIXME: We could actually describe this particular pkg-desc.
(describe-package (package-desc-name pkg-desc)))))
(describe-package pkg-desc)
(error "No package here"))))
;; fixme numeric argument
(defun package-menu-mark-delete (&optional _num)
@ -1614,10 +1679,6 @@ Optional argument NOQUERY non-nil means do not ask the user to confirm."
(package-delete elt)
(error (message (cadr err)))))
(error "Aborted")))
;; If we deleted anything, regenerate `package-alist'. This is done
;; automatically if we installed a package.
(and delete-list (null install-list)
(package-initialize))
(if (or delete-list install-list)
(package-menu--generate t t)
(message "No operations specified."))))

2
lisp/emacs-lisp/tabulated-list.el
View file

@ -230,7 +230,7 @@ If ADVANCE is non-nil, move forward by one line afterwards."
`(space :align-to ,(+ x shift)))
(cdr cols))))
(setq x (+ x shift)))))
(if (> pad-right 0)
(if (>= pad-right 0)
(push (propertize " "
'display `(space :align-to ,next-x)
'face 'fixed-pitch)

121
lisp/epg.el
View file

@ -190,8 +190,17 @@
cipher-algorithm digest-algorithm
compress-algorithm)
"Return a context object."
(unless protocol
(setq protocol 'OpenPGP))
(unless (memq protocol '(OpenPGP CMS))
(signal 'epg-error (list "unknown protocol" protocol)))
(cons 'epg-context
(vector (or protocol 'OpenPGP) armor textmode include-certs
(vector protocol
(if (eq protocol 'OpenPGP)
epg-gpg-program
epg-gpgsm-program)
epg-gpg-home-directory
armor textmode include-certs
cipher-algorithm digest-algorithm compress-algorithm
(list #'epg-passphrase-callback-function)
nil
@ -203,97 +212,109 @@
(signal 'wrong-type-argument (list 'epg-context-p context)))
(aref (cdr context) 0))
(defun epg-context-program (context)
"Return the gpg or gpgsm executable used within CONTEXT."
(unless (eq (car-safe context) 'epg-context)
(signal 'wrong-type-argument (list 'epg-context-p context)))
(aref (cdr context) 1))
(defun epg-context-home-directory (context)
"Return the GnuPG home directory used in CONTEXT."
(unless (eq (car-safe context) 'epg-context)
(signal 'wrong-type-argument (list 'epg-context-p context)))
(aref (cdr context) 2))
(defun epg-context-armor (context)
"Return t if the output should be ASCII armored in CONTEXT."
(unless (eq (car-safe context) 'epg-context)
(signal 'wrong-type-argument (list 'epg-context-p context)))
(aref (cdr context) 1))
(aref (cdr context) 3))
(defun epg-context-textmode (context)
"Return t if canonical text mode should be used in CONTEXT."
(unless (eq (car-safe context) 'epg-context)
(signal 'wrong-type-argument (list 'epg-context-p context)))
(aref (cdr context) 2))
(aref (cdr context) 4))
(defun epg-context-include-certs (context)
"Return how many certificates should be included in an S/MIME signed message."
(unless (eq (car-safe context) 'epg-context)
(signal 'wrong-type-argument (list 'epg-context-p context)))
(aref (cdr context) 3))
(aref (cdr context) 5))
(defun epg-context-cipher-algorithm (context)
"Return the cipher algorithm in CONTEXT."
(unless (eq (car-safe context) 'epg-context)
(signal 'wrong-type-argument (list 'epg-context-p context)))
(aref (cdr context) 4))
(aref (cdr context) 6))
(defun epg-context-digest-algorithm (context)
"Return the digest algorithm in CONTEXT."
(unless (eq (car-safe context) 'epg-context)
(signal 'wrong-type-argument (list 'epg-context-p context)))
(aref (cdr context) 5))
(aref (cdr context) 7))
(defun epg-context-compress-algorithm (context)
"Return the compress algorithm in CONTEXT."
(unless (eq (car-safe context) 'epg-context)
(signal 'wrong-type-argument (list 'epg-context-p context)))
(aref (cdr context) 6))
(aref (cdr context) 8))
(defun epg-context-passphrase-callback (context)
"Return the function used to query passphrase."
(unless (eq (car-safe context) 'epg-context)
(signal 'wrong-type-argument (list 'epg-context-p context)))
(aref (cdr context) 7))
(aref (cdr context) 9))
(defun epg-context-progress-callback (context)
"Return the function which handles progress update."
(unless (eq (car-safe context) 'epg-context)
(signal 'wrong-type-argument (list 'epg-context-p context)))
(aref (cdr context) 8))
(aref (cdr context) 10))
(defun epg-context-signers (context)
"Return the list of key-id for signing."
(unless (eq (car-safe context) 'epg-context)
(signal 'wrong-type-argument (list 'epg-context-p context)))
(aref (cdr context) 9))
(aref (cdr context) 11))
(defun epg-context-sig-notations (context)
"Return the list of notations for signing."
(unless (eq (car-safe context) 'epg-context)
(signal 'wrong-type-argument (list 'epg-context-p context)))
(aref (cdr context) 10))
(aref (cdr context) 12))
(defun epg-context-process (context)
"Return the process object of `epg-gpg-program'.
This function is for internal use only."
(unless (eq (car-safe context) 'epg-context)
(signal 'wrong-type-argument (list 'epg-context-p context)))
(aref (cdr context) 11))
(aref (cdr context) 13))
(defun epg-context-output-file (context)
"Return the output file of `epg-gpg-program'.
This function is for internal use only."
(unless (eq (car-safe context) 'epg-context)
(signal 'wrong-type-argument (list 'epg-context-p context)))
(aref (cdr context) 12))
(aref (cdr context) 14))
(defun epg-context-result (context)
"Return the result of the previous cryptographic operation."
(unless (eq (car-safe context) 'epg-context)
(signal 'wrong-type-argument (list 'epg-context-p context)))
(aref (cdr context) 13))
(aref (cdr context) 15))
(defun epg-context-operation (context)
"Return the name of the current cryptographic operation."
(unless (eq (car-safe context) 'epg-context)
(signal 'wrong-type-argument (list 'epg-context-p context)))
(aref (cdr context) 14))
(aref (cdr context) 16))
(defun epg-context-pinentry-mode (context)
"Return the mode of pinentry invocation."
(unless (eq (car-safe context) 'epg-context)
(signal 'wrong-type-argument (list 'epg-context-p context)))
(aref (cdr context) 15))
(aref (cdr context) 17))
(defun epg-context-set-protocol (context protocol)
"Set the protocol used within CONTEXT."
@ -301,41 +322,53 @@ This function is for internal use only."
(signal 'wrong-type-argument (list 'epg-context-p context)))
(aset (cdr context) 0 protocol))
(defun epg-context-set-program (context protocol)
"Set the gpg or gpgsm executable used within CONTEXT."
(unless (eq (car-safe context) 'epg-context)
(signal 'wrong-type-argument (list 'epg-context-p context)))
(aset (cdr context) 1 protocol))
(defun epg-context-set-home-directory (context directory)
"Set the GnuPG home directory."
(unless (eq (car-safe context) 'epg-context)
(signal 'wrong-type-argument (list 'epg-context-p context)))
(aset (cdr context) 2 directory))
(defun epg-context-set-armor (context armor)
"Specify if the output should be ASCII armored in CONTEXT."
(unless (eq (car-safe context) 'epg-context)
(signal 'wrong-type-argument (list 'epg-context-p context)))
(aset (cdr context) 1 armor))
(aset (cdr context) 3 armor))
(defun epg-context-set-textmode (context textmode)
"Specify if canonical text mode should be used in CONTEXT."
(unless (eq (car-safe context) 'epg-context)
(signal 'wrong-type-argument (list 'epg-context-p context)))
(aset (cdr context) 2 textmode))
(aset (cdr context) 4 textmode))
(defun epg-context-set-include-certs (context include-certs)
"Set how many certificates should be included in an S/MIME signed message."
(unless (eq (car-safe context) 'epg-context)
(signal 'wrong-type-argument (list 'epg-context-p context)))
(aset (cdr context) 3 include-certs))
(aset (cdr context) 5 include-certs))
(defun epg-context-set-cipher-algorithm (context cipher-algorithm)
"Set the cipher algorithm in CONTEXT."
(unless (eq (car-safe context) 'epg-context)
(signal 'wrong-type-argument (list 'epg-context-p context)))
(aset (cdr context) 4 cipher-algorithm))
(aset (cdr context) 6 cipher-algorithm))
(defun epg-context-set-digest-algorithm (context digest-algorithm)
"Set the digest algorithm in CONTEXT."
(unless (eq (car-safe context) 'epg-context)
(signal 'wrong-type-argument (list 'epg-context-p context)))
(aset (cdr context) 5 digest-algorithm))
(aset (cdr context) 7 digest-algorithm))
(defun epg-context-set-compress-algorithm (context compress-algorithm)
"Set the compress algorithm in CONTEXT."
(unless (eq (car-safe context) 'epg-context)
(signal 'wrong-type-argument (list 'epg-context-p context)))
(aset (cdr context) 6 compress-algorithm))
(aset (cdr context) 8 compress-algorithm))
(defun epg-context-set-passphrase-callback (context
passphrase-callback)
@ -354,7 +387,7 @@ installing GnuPG 1.x _along with_ GnuPG 2.x, which does passphrase
query by itself and Emacs can intercept them."
(unless (eq (car-safe context) 'epg-context)
(signal 'wrong-type-argument (list 'epg-context-p context)))
(aset (cdr context) 7 (if (consp passphrase-callback)
(aset (cdr context) 9 (if (consp passphrase-callback)
passphrase-callback
(list passphrase-callback))))
@ -371,7 +404,7 @@ current amount done, the total amount to be done, and the
callback data (if any)."
(unless (eq (car-safe context) 'epg-context)
(signal 'wrong-type-argument (list 'epg-context-p context)))
(aset (cdr context) 8 (if (consp progress-callback)
(aset (cdr context) 10 (if (consp progress-callback)
progress-callback
(list progress-callback))))
@ -379,39 +412,39 @@ callback data (if any)."
"Set the list of key-id for signing."
(unless (eq (car-safe context) 'epg-context)
(signal 'wrong-type-argument (list 'epg-context-p context)))
(aset (cdr context) 9 signers))
(aset (cdr context) 11 signers))
(defun epg-context-set-sig-notations (context notations)
"Set the list of notations for signing."
(unless (eq (car-safe context) 'epg-context)
(signal 'wrong-type-argument (list 'epg-context-p context)))
(aset (cdr context) 10 notations))
(aset (cdr context) 12 notations))
(defun epg-context-set-process (context process)
"Set the process object of `epg-gpg-program'.
This function is for internal use only."
(unless (eq (car-safe context) 'epg-context)
(signal 'wrong-type-argument (list 'epg-context-p context)))
(aset (cdr context) 11 process))
(aset (cdr context) 13 process))
(defun epg-context-set-output-file (context output-file)
"Set the output file of `epg-gpg-program'.
This function is for internal use only."
(unless (eq (car-safe context) 'epg-context)
(signal 'wrong-type-argument (list 'epg-context-p context)))
(aset (cdr context) 12 output-file))
(aset (cdr context) 14 output-file))
(defun epg-context-set-result (context result)
"Set the result of the previous cryptographic operation."
(unless (eq (car-safe context) 'epg-context)
(signal 'wrong-type-argument (list 'epg-context-p context)))
(aset (cdr context) 13 result))
(aset (cdr context) 15 result))
(defun epg-context-set-operation (context operation)
"Set the name of the current cryptographic operation."
(unless (eq (car-safe context) 'epg-context)
(signal 'wrong-type-argument (list 'epg-context-p context)))
(aset (cdr context) 14 operation))
(aset (cdr context) 16 operation))
(defun epg-context-set-pinentry-mode (context mode)
"Set the mode of pinentry invocation."
@ -419,7 +452,7 @@ This function is for internal use only."
(signal 'wrong-type-argument (list 'epg-context-p context)))
(unless (memq mode '(nil ask cancel error loopback))
(signal 'epg-error (list "Unknown pinentry mode" mode)))
(aset (cdr context) 15 mode))
(aset (cdr context) 17 mode))
(defun epg-make-signature (status &optional key-id)
"Return a signature object."
@ -1145,9 +1178,7 @@ This function is for internal use only."
(if (and (epg-context-process context)
(eq (process-status (epg-context-process context)) 'run))
(error "%s is already running in this context"
(if (eq (epg-context-protocol context) 'CMS)
epg-gpgsm-program
epg-gpg-program)))
(epg-context-program context)))
(let* ((agent-info (getenv "GPG_AGENT_INFO"))
(args (append (list "--no-tty"
"--status-fd" "1"
@ -1158,8 +1189,9 @@ This function is for internal use only."
(if (and (not (eq (epg-context-protocol context) 'CMS))
(epg-context-progress-callback context))
'("--enable-progress-filter"))
(if epg-gpg-home-directory
(list "--homedir" epg-gpg-home-directory))
(if (epg-context-home-directory context)
(list "--homedir"
(epg-context-home-directory context)))
(unless (eq (epg-context-protocol context) 'CMS)
'("--command-fd" "0"))
(if (epg-context-armor context) '("--armor"))
@ -1213,9 +1245,7 @@ This function is for internal use only."
(format "GPG_AGENT_INFO=%s\n" agent-info)
"GPG_AGENT_INFO is not set\n")
(format "%s %s\n"
(if (eq (epg-context-protocol context) 'CMS)
epg-gpgsm-program
epg-gpg-program)
(epg-context-program context)
(mapconcat #'identity args " ")))))
(with-current-buffer buffer
(if (fboundp 'set-buffer-multibyte)
@ -1241,9 +1271,7 @@ This function is for internal use only."
(set-default-file-modes 448)
(setq process
(apply #'start-process "epg" buffer
(if (eq (epg-context-protocol context) 'CMS)
epg-gpgsm-program
epg-gpg-program)
(epg-context-program context)
args)))
(set-default-file-modes orig-mode))
(set-process-filter process #'epg--process-filter)
@ -1854,8 +1882,9 @@ This function is for internal use only."
(format "Passphrase for %s: " key-id)))))))
(defun epg--list-keys-1 (context name mode)
(let ((args (append (if epg-gpg-home-directory
(list "--homedir" epg-gpg-home-directory))
(let ((args (append (if (epg-context-home-directory context)
(list "--homedir"
(epg-context-home-directory context)))
'("--with-colons" "--no-greeting" "--batch"
"--with-fingerprint" "--with-fingerprint")
(unless (eq (epg-context-protocol context) 'CMS)
@ -1877,9 +1906,7 @@ This function is for internal use only."
(setq args (append args (list list-keys-option))))
(with-temp-buffer
(apply #'call-process
(if (eq (epg-context-protocol context) 'CMS)
epg-gpgsm-program
epg-gpg-program)
(epg-context-program context)
nil (list t nil) nil args)
(goto-char (point-min))
(while (re-search-forward "^[a-z][a-z][a-z]:.*" nil t)

22
lisp/faces.el
View file

@ -536,11 +536,9 @@ Use `face-attribute' for finer control."
(defun face-documentation (face)
"Get the documentation string for FACE.
If FACE is a face-alias, get the documentation for the target face."
(let ((alias (get face 'face-alias))
doc)
(let ((alias (get face 'face-alias)))
(if alias
(progn
(setq doc (get alias 'face-documentation))
(let ((doc (get alias 'face-documentation)))
(format "%s is an alias for the face `%s'.%s" face alias
(if doc (format "\n%s" doc)
"")))
@ -1171,7 +1169,7 @@ of a global face. Value is the new attribute value."
;; pixmap file name won't start with an open-paren.
(and (memq attribute '(:stipple :box :underline))
(stringp new-value)
(string-match "^[[(]" new-value)
(string-match-p "^[[(]" new-value)
(setq new-value (read new-value)))
new-value))
@ -1272,7 +1270,7 @@ arg, prompt for a regular expression."
(delq nil
(mapcar (lambda (f)
(let ((s (symbol-name f)))
(when (or all-faces (string-match regexp s))
(when (or all-faces (string-match-p regexp s))
(setq max-length (max (length s) max-length))
f)))
(sort (face-list) #'string-lessp))))
@ -1328,10 +1326,8 @@ arg, prompt for a regular expression."
(setq disp-frame (if window (window-frame window)
(car (frame-list))))
(or (eq frame disp-frame)
(let ((faces (face-list)))
(while faces
(copy-face (car faces) (car faces) frame disp-frame)
(setq faces (cdr faces)))))))
(dolist (face (face-list))
(copy-face face face frame disp-frame)))))
(defun describe-face (face &optional frame)
@ -1850,7 +1846,7 @@ resulting color name in the echo area."
(when (and convert-to-RGB
(not (string-equal color "")))
(let ((components (x-color-values color)))
(unless (string-match "^#\\([a-fA-F0-9][a-fA-F0-9][a-fA-F0-9]\\)+$" color)
(unless (string-match-p "^#\\(?:[a-fA-F0-9][a-fA-F0-9][a-fA-F0-9]\\)+$" color)
(setq color (format "#%04X%04X%04X"
(logand 65535 (nth 0 components))
(logand 65535 (nth 1 components))
@ -2096,7 +2092,7 @@ the above example."
(not (funcall pred type)))
;; Strip off last hyphen and what follows, then try again
(setq type
(if (setq hyphend (string-match "[-_][^-_]+$" type))
(if (setq hyphend (string-match-p "[-_][^-_]+$" type))
(substring type 0 hyphend)
nil))))
type)
@ -2617,7 +2613,7 @@ also the same size as FACE on FRAME, or fail."
(let ((fonts (x-list-fonts pattern face frame 1)))
(or fonts
(if face
(if (string-match "\\*" pattern)
(if (string-match-p "\\*" pattern)
(if (null (face-font face))
(error "No matching fonts are the same height as the frame default font")
(error "No matching fonts are the same height as face `%s'" face))

78
lisp/files-x.el
View file

@ -38,11 +38,10 @@
Intended to be used in the `interactive' spec of
`add-file-local-variable', `delete-file-local-variable',
`add-dir-local-variable', `delete-dir-local-variable'."
(let (default variable)
(setq default (variable-at-point))
(setq default (and (symbolp default) (boundp default)
(let* ((default (variable-at-point))
(default (and (symbolp default) (boundp default)
(symbol-name default)))
(setq variable
(variable
(completing-read
(if default
(format "%s (default %s): " prompt default)
@ -52,48 +51,47 @@ Intended to be used in the `interactive' spec of
(or (custom-variable-p sym)
(get sym 'safe-local-variable)
(memq sym '(mode eval coding unibyte))))
nil nil nil default nil))
nil nil nil default nil)))
(and (stringp variable) (intern variable))))
(defun read-file-local-variable-value (variable)
"Read value of file-local VARIABLE using completion.
Intended to be used in the `interactive' spec of
`add-file-local-variable' and `add-dir-local-variable'."
(let (default value)
(cond
((eq variable 'mode)
(setq default (and (symbolp major-mode) (symbol-name major-mode)))
(setq value
(completing-read
(if default
(format "Add %s with value (default %s): " variable default)
(format "Add %s with value: " variable))
obarray
(lambda (sym)
(string-match-p "-mode\\'" (symbol-name sym)))
nil nil nil default nil))
(cond
((eq variable 'mode)
(let* ((default (and (symbolp major-mode) (symbol-name major-mode)))
(value
(completing-read
(if default
(format "Add %s with value (default %s): " variable default)
(format "Add %s with value: " variable))
obarray
(lambda (sym)
(string-match-p "-mode\\'" (symbol-name sym)))
nil nil nil default nil)))
(and (stringp value)
(intern (replace-regexp-in-string "-mode\\'" "" value))))
((eq variable 'eval)
(let ((minibuffer-completing-symbol t))
(read-from-minibuffer (format "Add %s with expression: " variable)
nil read-expression-map t
'read-expression-history)))
((eq variable 'coding)
(setq default (and (symbolp buffer-file-coding-system)
(symbol-name buffer-file-coding-system)))
(intern (replace-regexp-in-string "-mode\\'" "" value)))))
((eq variable 'eval)
(read--expression (format "Add %s with expression: " variable)))
((eq variable 'coding)
(let ((default (and (symbolp buffer-file-coding-system)
(symbol-name buffer-file-coding-system))))
(read-coding-system
(if default
(format "Add %s with value (default %s): " variable default)
(format "Add %s with value: " variable))
default))
(t
(read (read-string (format "Add %s with value: " variable)
nil 'set-variable-value-history
(format "%S"
(cond ((eq variable 'unibyte) t)
((boundp variable)
(symbol-value variable))))))))))
(format "Add %s with value (default %s): " variable default)
(format "Add %s with value: " variable))
default)))
(t
(let ((default (format "%S"
(cond ((eq variable 'unibyte) t)
((boundp variable)
(symbol-value variable)))))
(minibuffer-completing-symbol t))
(read-from-minibuffer (format "Add %s with value: " variable)
nil read-expression-map t
'set-variable-value-history
default)))))
(defun read-file-local-variable-mode ()
"Read per-directory file-local variable's mode using completion.
@ -108,7 +106,9 @@ Intended to be used in the `interactive' spec of
obarray
(lambda (sym)
(and (string-match-p "-mode\\'" (symbol-name sym))
(not (string-match-p "-minor-mode\\'" (symbol-name sym)))))
(not (or (memq sym minor-mode-list)
(string-match-p "-minor-mode\\'"
(symbol-name sym))))))
nil nil nil default nil)))
(cond
((equal mode "nil") nil)
@ -476,7 +476,7 @@ from the MODE alist ignoring the input argument VALUE."
;; Insert modified alist of directory-local variables.
(insert ";;; Directory Local Variables\n")
(insert ";;; See Info node `(emacs) Directory Variables' for more information.\n\n")
(insert ";;; For more information see (info \"(emacs) Directory Variables\")\n\n")
(pp (sort variables
(lambda (a b)
(cond

5
lisp/gnus/ChangeLog
View file

@ -1,3 +1,8 @@
2013-06-28 Katsumi Yamaoka <yamaoka@jpl.org>
* gnus-art.el (gnus-article-extend-url-button): Make it work again with
gnus-button-push revised at 2011-01-19.
2013-06-19 Glenn Morris <rgm@gnu.org>
* gnus-group.el (gnus-mark-article-as-read): Fix declaration.

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

@ -7866,7 +7866,9 @@ url is put as the `gnus-button-url' overlay property on the button."
(let (gnus-article-mouse-face widget-mouse-face)
(while points
(gnus-article-add-button (pop points) (pop points)
'gnus-button-push beg)))
'gnus-button-push
(list beg (assq 'gnus-button-url-regexp
gnus-button-alist)))))
(let ((overlay (gnus-make-overlay start end)))
(gnus-overlay-put overlay 'evaporate t)
(gnus-overlay-put overlay 'gnus-button-url

6
lisp/htmlfontify.el
View file

@ -748,6 +748,10 @@ if you've redefined white, (esp. if you've redefined it to have a triplet
member lower than that of the color you are processing) strange things
may happen."
;;(message "hfy-colour-vals");;DBUG
;; TODO? Can we do somehow do better than this?
(cond
((equal colour "unspecified-fg") (setq colour "black"))
((equal colour "unspecified-bg") (setq colour "white")))
(let ((white (mapcar (lambda (I) (float (1+ I))) (hfy-colour-vals "white")))
(rgb16 (mapcar (lambda (I) (float (1+ I))) (hfy-colour-vals colour))))
(if rgb16
@ -773,6 +777,8 @@ may happen."
"Derive a CSS font-size specifier from an Emacs font :height attribute HEIGHT.
Does not cope with the case where height is a function to be applied to
the height of the underlying font."
;; In ttys, the default face has :height == 1.
(and (not (display-graphic-p)) (equal 1 height) (setq height 100))
(list
(cond
;;(t (cons "font-size" ": 1em"))

7
lisp/ido.el
View file

@ -2141,9 +2141,10 @@ If INITIAL is non-nil, it specifies the initial input string."
done t)
(setq ido-set-default-item t)))
((or (string-match "[/\\][^/\\]" ido-selected)
(and (memq system-type '(windows-nt ms-dos))
(string-match "\\`[a-zA-Z]:" ido-selected)))
((string-match (if (memq system-type '(windows-nt ms-dos))
"\\`[a-zA-Z]:\\|[/\\][^/\\]"
"/[^/]")
ido-selected)
(ido-set-current-directory (file-name-directory ido-selected))
(setq ido-set-default-item t))

21
lisp/info-xref.el
View file

@ -367,13 +367,28 @@ in the path."
(forward-line)))
(info-xref-check-buffer))))))))
(defconst info-xref-node-re "\\(?1:\\(([^)]*)\\)[^.,]+\\)"
"Regexp with subexp 1 matching (manual)node.")
;; "@xref{node,crossref,manual}." produces:
;; texinfo 4 or 5:
;; *Note crossref: (manual)node.
;; "@xref{node,,manual}." produces:
;; texinfo 4:
;; *Note node: (manual)node.
;; texinfo 5:
;; *Note (manual)node::.
(defconst info-xref-note-re
(concat "\\*[Nn]ote[ \n\t]+\\(?:"
"[^:]*:[ \n\t]+" info-xref-node-re "\\|"
info-xref-node-re "::\\)[.,]")
"Regexp matching a \"*note...\" link.")
(defun info-xref-check-buffer ()
"Check external references in the info file in the current buffer.
This should be the raw file contents, not `Info-mode'."
(goto-char (point-min))
(while (re-search-forward
"\\*[Nn]ote[ \n\t]+[^:]*:[ \n\t]+\\(\\(([^)]*)\\)[^.,]+\\)[.,]"
nil t)
(while (re-search-forward info-xref-note-re nil t)
(save-excursion
(goto-char (match-beginning 1)) ;; start of nodename as error position
(info-xref-check-node (match-string 1)))))

36
lisp/info.el
View file

@ -3870,23 +3870,6 @@ If FORK is non-nil, it is passed to `Info-goto-node'."
((setq node (Info-get-token (point) "\\*note[ \n\t]+"
"\\*note[ \n\t]+\\([^:]*\\):\\(:\\|[ \n\t]*(\\)?"))
(Info-follow-reference node fork))
;; menu item: node name
((setq node (Info-get-token (point) "\\* +" "\\* +\\([^:]*\\)::"))
(Info-goto-node node fork))
;; menu item: node name or index entry
((Info-get-token (point) "\\* +" "\\* +\\(.*\\): ")
(beginning-of-line)
(forward-char 2)
(setq node (Info-extract-menu-node-name nil (Info-index-node)))
(Info-goto-node node fork))
((setq node (Info-get-token (point) "Up: " "Up: \\([^,\n\t]*\\)"))
(Info-goto-node node fork))
((setq node (Info-get-token (point) "Next: " "Next: \\([^,\n\t]*\\)"))
(Info-goto-node node fork))
((setq node (Info-get-token (point) "File: " "File: \\([^,\n\t]*\\)"))
(Info-goto-node "Top" fork))
((setq node (Info-get-token (point) "Prev: " "Prev: \\([^,\n\t]*\\)"))
(Info-goto-node node fork))
;; footnote
((setq node (Info-get-token (point) "(" "\\(([0-9]+)\\)"))
(let ((old-point (point)) new-point)
@ -3904,7 +3887,24 @@ If FORK is non-nil, it is passed to `Info-goto-node'."
(progn
(goto-char new-point)
(setq node t))
(setq node nil)))))
(setq node nil))))
;; menu item: node name
((setq node (Info-get-token (point) "\\* +" "\\* +\\([^:]*\\)::"))
(Info-goto-node node fork))
;; menu item: node name or index entry
((Info-get-token (point) "\\* +" "\\* +\\(.*\\): ")
(beginning-of-line)
(forward-char 2)
(setq node (Info-extract-menu-node-name nil (Info-index-node)))
(Info-goto-node node fork))
((setq node (Info-get-token (point) "Up: " "Up: \\([^,\n\t]*\\)"))
(Info-goto-node node fork))
((setq node (Info-get-token (point) "Next: " "Next: \\([^,\n\t]*\\)"))
(Info-goto-node node fork))
((setq node (Info-get-token (point) "File: " "File: \\([^,\n\t]*\\)"))
(Info-goto-node "Top" fork))
((setq node (Info-get-token (point) "Prev: " "Prev: \\([^,\n\t]*\\)"))
(Info-goto-node node fork)))
node))
(defun Info-mouse-follow-link (click)

323
lisp/net/eww.el
View file

@ -40,6 +40,19 @@
"Header line format.
- %t is replaced by the title.
- %u is replaced by the URL."
:version "24.4"
:group 'eww
:type 'string)
(defcustom eww-search-prefix "https://duckduckgo.com/html/?q="
"Prefix URL to search engine"
:version "24.4"
:group 'eww
:type 'string)
(defcustom eww-download-path "~/Downloads/"
"Path where files will downloaded."
:version "24.4"
:group 'eww
:type 'string)
@ -79,6 +92,7 @@
(defvar eww-current-title ""
"Title of current page.")
(defvar eww-history nil)
(defvar eww-history-position 0)
(defvar eww-next-url nil)
(defvar eww-previous-url nil)
@ -89,10 +103,21 @@
;;;###autoload
(defun eww (url)
"Fetch URL and render the page."
(interactive "sUrl: ")
(unless (string-match-p "\\`[a-zA-Z][-a-zA-Z0-9+.]*://" url)
(setq url (concat "http://" url)))
"Fetch URL and render the page.
If the input doesn't look like an URL or a domain name, the
word(s) will be searched for via `eww-search-prefix'."
(interactive "sEnter URL or keywords: ")
(if (and (= (length (split-string url)) 1)
(> (length (split-string url "\\.")) 1))
(progn
(unless (string-match-p "\\`[a-zA-Z][-a-zA-Z0-9+.]*://" url)
(setq url (concat "http://" url)))
;; some site don't redirect final /
(when (string= (url-filename (url-generic-parse-url url)) "")
(setq url (concat url "/"))))
(unless (string-match-p "\\'file:" url)
(setq url (concat eww-search-prefix
(replace-regexp-in-string " " "+" url)))))
(url-retrieve url 'eww-render (list url)))
;;;###autoload
@ -135,6 +160,7 @@
(eww-display-image))
(t
(eww-display-raw charset)))
(setq eww-history-position 0)
(cond
(point
(goto-char point))
@ -164,7 +190,7 @@
(pt (point)))
(or (and html-p
(re-search-forward
"<meta[\t\n\r ]+[^>]*charset=\"?\\([^\t\n\r \"/>]+\\)" nil t)
"<meta[\t\n\r ]+[^>]*charset=\"?\\([^\t\n\r \"/>]+\\)[\\\"'.*]" nil t)
(goto-char pt)
(match-string 1))
(and (looking-at
@ -284,10 +310,11 @@
(defun eww-setup-buffer ()
(pop-to-buffer (get-buffer-create "*eww*"))
(remove-overlays)
(let ((inhibit-read-only t))
(remove-overlays)
(erase-buffer))
(eww-mode))
(unless (eq major-mode 'eww-mode)
(eww-mode)))
(defvar eww-mode-map
(let ((map (make-sparse-keymap)))
@ -300,10 +327,35 @@
(define-key map "\177" 'scroll-down-command)
(define-key map " " 'scroll-up-command)
(define-key map "l" 'eww-back-url)
(define-key map "f" 'eww-forward-url)
(define-key map "n" 'eww-next-url)
(define-key map "p" 'eww-previous-url)
(define-key map "u" 'eww-up-url)
(define-key map "t" 'eww-top-url)
(define-key map "&" 'eww-browse-with-external-browser)
(define-key map "d" 'eww-download)
(define-key map "w" 'eww-copy-page-url)
(define-key map "C" 'url-cookie-list)
(define-key map "b" 'eww-add-bookmark)
(define-key map "B" 'eww-list-bookmarks)
(define-key map [(meta n)] 'eww-next-bookmark)
(define-key map [(meta p)] 'eww-previous-bookmark)
(easy-menu-define nil map ""
'("eww"
["Quit" eww-quit t]
["Reload" eww-reload t]
["Back to previous page" eww-back-url
:active (not (zerop (length eww-history)))]
["Forward to next page" eww-forward-url
:active (not (zerop eww-history-position))]
["Browse with external browser" eww-browse-with-external-browser t]
["Download" eww-download t]
["Copy page URL" eww-copy-page-url t]
["Add bookmark" eww-add-bookmark t]
["List bookmarks" eww-copy-page-url t]
["List cookies" url-cookie-list t]))
map))
(define-derived-mode eww-mode nil "eww"
@ -313,14 +365,24 @@
(set (make-local-variable 'eww-current-url) 'author)
(set (make-local-variable 'browse-url-browser-function) 'eww-browse-url)
(set (make-local-variable 'after-change-functions) 'eww-process-text-input)
(set (make-local-variable 'eww-history) nil)
(set (make-local-variable 'eww-history-position) 0)
(buffer-disable-undo)
;;(setq buffer-read-only t)
)
(defun eww-save-history ()
(push (list :url eww-current-url
:title eww-current-title
:point (point)
:text (buffer-string))
eww-history))
;;;###autoload
(defun eww-browse-url (url &optional new-window)
(when (and (equal major-mode 'eww-mode)
eww-current-url)
(push (list eww-current-url (point))
eww-history))
(eww-save-history))
(eww url))
(defun eww-quit ()
@ -332,10 +394,27 @@
(defun eww-back-url ()
"Go to the previously displayed page."
(interactive)
(when (zerop (length eww-history))
(when (>= eww-history-position (length eww-history))
(error "No previous page"))
(let ((prev (pop eww-history)))
(url-retrieve (car prev) 'eww-render (list (car prev) (cadr prev)))))
(eww-save-history)
(setq eww-history-position (+ eww-history-position 2))
(eww-restore-history (elt eww-history (1- eww-history-position))))
(defun eww-forward-url ()
"Go to the next displayed page."
(interactive)
(when (zerop eww-history-position)
(error "No next page"))
(eww-save-history)
(eww-restore-history (elt eww-history (1- eww-history-position))))
(defun eww-restore-history (elem)
(let ((inhibit-read-only t))
(erase-buffer)
(insert (plist-get elem :text))
(goto-char (plist-get elem :point))
(setq eww-current-url (plist-get elem :url)
eww-current-title (plist-get elem :title))))
(defun eww-next-url ()
"Go to the page marked `next'.
@ -389,12 +468,14 @@ appears in a <link> or <a> tag."
(defvar eww-submit-map
(let ((map (make-sparse-keymap)))
(define-key map "\r" 'eww-submit)
(define-key map [(control c) (control c)] 'eww-submit)
map))
(defvar eww-checkbox-map
(let ((map (make-sparse-keymap)))
(define-key map [space] 'eww-toggle-checkbox)
(define-key map "\r" 'eww-toggle-checkbox)
(define-key map [(control c) (control c)] 'eww-submit)
map))
(defvar eww-text-map
@ -402,6 +483,7 @@ appears in a <link> or <a> tag."
(set-keymap-parent map text-mode-map)
(define-key map "\r" 'eww-submit)
(define-key map [(control a)] 'eww-beginning-of-text)
(define-key map [(control c) (control c)] 'eww-submit)
(define-key map [(control e)] 'eww-end-of-text)
(define-key map [tab] 'shr-next-link)
(define-key map [backtab] 'shr-previous-link)
@ -411,6 +493,7 @@ appears in a <link> or <a> tag."
(let ((map (make-keymap)))
(set-keymap-parent map text-mode-map)
(define-key map "\r" 'forward-line)
(define-key map [(control c) (control c)] 'eww-submit)
(define-key map [tab] 'shr-next-link)
(define-key map [backtab] 'shr-previous-link)
map))
@ -418,6 +501,7 @@ appears in a <link> or <a> tag."
(defvar eww-select-map
(let ((map (make-sparse-keymap)))
(define-key map "\r" 'eww-change-select)
(define-key map [(control c) (control c)] 'eww-submit)
map))
(defun eww-beginning-of-text ()
@ -810,6 +894,221 @@ appears in a <link> or <a> tag."
"?"
(mm-url-encode-www-form-urlencoded values))))))
(defun eww-browse-with-external-browser ()
"Browse the current URL with an external browser.
The browser to used is specified by the `shr-external-browser' variable."
(interactive)
(funcall shr-external-browser eww-current-url))
(defun eww-copy-page-url ()
(interactive)
(message "%s" eww-current-url)
(kill-new eww-current-url))
(defun eww-download ()
"Download URL under point to `eww-download-directory'."
(interactive)
(let ((url (get-text-property (point) 'shr-url)))
(if (not url)
(message "No URL under point")
(url-retrieve url 'eww-download-callback (list url)))))
(defun eww-download-callback (status url)
(unless (plist-get status :error)
(let* ((obj (url-generic-parse-url url))
(path (car (url-path-and-query obj)))
(file (eww-make-unique-file-name (file-name-nondirectory path)
eww-download-path)))
(write-file file)
(message "Saved %s" file))))
(defun eww-make-unique-file-name (file directory)
(cond
((zerop (length file))
(setq file "!"))
((string-match "\\`[.]" file)
(setq file (concat "!" file))))
(let ((base file)
(count 1))
(while (file-exists-p (expand-file-name file directory))
(setq file
(if (string-match "\\`\\(.*\\)\\([.][^.]+\\)" file)
(format "%s(%d)%s" (match-string 1 file)
count (match-string 2 file))
(format "%s(%d)" file count)))
(setq count (1+ count)))
(expand-file-name file directory)))
;;; Bookmarks code
(defvar eww-bookmarks nil)
(defun eww-add-bookmark ()
"Add the current page to the bookmarks."
(interactive)
(eww-read-bookmarks)
(dolist (bookmark eww-bookmarks)
(when (equal eww-current-url
(plist-get bookmark :url))
(error "Already bookmarked")))
(let ((title (replace-regexp-in-string "[\n\t\r]" " " eww-current-title)))
(setq title (replace-regexp-in-string "\\` +\\| +\\'" "" title))
(push (list :url eww-current-url
:title title
:time (current-time-string))
eww-bookmarks))
(eww-write-bookmarks)
(message "Bookmarked %s (%s)" eww-current-url eww-current-title))
(defun eww-write-bookmarks ()
(with-temp-file (expand-file-name "eww-bookmarks" user-emacs-directory)
(insert ";; Auto-generated file; don't edit\n")
(pp eww-bookmarks (current-buffer))))
(defun eww-read-bookmarks ()
(let ((file (expand-file-name "eww-bookmarks" user-emacs-directory)))
(setq eww-bookmarks
(unless (zerop (or (nth 7 (file-attributes file)) 0))
(with-temp-buffer
(insert-file-contents file)
(read (current-buffer)))))))
(defun eww-list-bookmarks ()
"Display the bookmarks."
(interactive)
(eww-bookmark-prepare)
(pop-to-buffer "*eww bookmarks*"))
(defun eww-bookmark-prepare ()
(eww-read-bookmarks)
(when (null eww-bookmarks)
(error "No bookmarks are defined"))
(set-buffer (get-buffer-create "*eww bookmarks*"))
(eww-bookmark-mode)
(let ((format "%-40s %s")
(inhibit-read-only t)
start url)
(erase-buffer)
(setq header-line-format (concat " " (format format "URL" "Title")))
(dolist (bookmark eww-bookmarks)
(setq start (point))
(setq url (plist-get bookmark :url))
(when (> (length url) 40)
(setq url (substring url 0 40)))
(insert (format format url
(plist-get bookmark :title))
"\n")
(put-text-property start (1+ start) 'eww-bookmark bookmark))
(goto-char (point-min))))
(defvar eww-bookmark-kill-ring nil)
(defun eww-bookmark-kill ()
"Kill the current bookmark."
(interactive)
(let* ((start (line-beginning-position))
(bookmark (get-text-property start 'eww-bookmark))
(inhibit-read-only t))
(unless bookmark
(error "No bookmark on the current line"))
(forward-line 1)
(push (buffer-substring start (point)) eww-bookmark-kill-ring)
(delete-region start (point))
(setq eww-bookmarks (delq bookmark eww-bookmarks))
(eww-write-bookmarks)))
(defun eww-bookmark-yank ()
"Yank a previously killed bookmark to the current line."
(interactive)
(unless eww-bookmark-kill-ring
(error "No previously killed bookmark"))
(beginning-of-line)
(let ((inhibit-read-only t)
(start (point))
bookmark)
(insert (pop eww-bookmark-kill-ring))
(setq bookmark (get-text-property start 'eww-bookmark))
(if (= start (point-min))
(push bookmark eww-bookmarks)
(let ((line (count-lines start (point))))
(setcdr (nthcdr (1- line) eww-bookmarks)
(cons bookmark (nthcdr line eww-bookmarks)))))
(eww-write-bookmarks)))
(defun eww-bookmark-quit ()
"Kill the current buffer."
(interactive)
(kill-buffer (current-buffer)))
(defun eww-bookmark-browse ()
"Browse the bookmark under point in eww."
(interactive)
(let ((bookmark (get-text-property (line-beginning-position) 'eww-bookmark)))
(unless bookmark
(error "No bookmark on the current line"))
;; We wish to leave this window, but if it's the only window here,
;; just let it remain.
(ignore-errors
(delete-window))
(eww (plist-get bookmark :url))))
(defun eww-next-bookmark ()
"Go to the next bookmark in the list."
(interactive)
(let ((first nil)
bookmark)
(unless (get-buffer "*eww bookmarks*")
(setq first t)
(eww-bookmark-prepare))
(with-current-buffer (get-buffer "*eww bookmarks*")
(when (and (not first)
(not (eobp)))
(forward-line 1))
(setq bookmark (get-text-property (line-beginning-position)
'eww-bookmark))
(unless bookmark
(error "No next bookmark")))
(eww-browse-url (plist-get bookmark :url))))
(defun eww-previous-bookmark ()
"Go to the previous bookmark in the list."
(interactive)
(let ((first nil)
bookmark)
(unless (get-buffer "*eww bookmarks*")
(setq first t)
(eww-bookmark-prepare))
(with-current-buffer (get-buffer "*eww bookmarks*")
(if first
(goto-char (point-max))
(beginning-of-line))
;; On the final line.
(when (eolp)
(forward-line -1))
(if (bobp)
(error "No previous bookmark")
(forward-line -1))
(setq bookmark (get-text-property (line-beginning-position)
'eww-bookmark)))
(eww-browse-url (plist-get bookmark :url))))
(defvar eww-bookmark-mode-map
(let ((map (make-sparse-keymap)))
(suppress-keymap map)
(define-key map "q" 'eww-bookmark-quit)
(define-key map [(control k)] 'eww-bookmark-kill)
(define-key map [(control y)] 'eww-bookmark-yank)
(define-key map "\r" 'eww-bookmark-browse)
map))
(define-derived-mode eww-bookmark-mode nil "eww bookmarks"
"Mode for listing bookmarks.
\\{eww-bookmark-mode-map}"
(buffer-disable-undo)
(setq buffer-read-only t
truncate-lines t))
(provide 'eww)
;;; eww.el ends here

93
lisp/net/shr.el
View file

@ -37,7 +37,7 @@
(defgroup shr nil
"Simple HTML Renderer"
:version "24.1"
:group 'mail)
:group 'hypermedia)
(defcustom shr-max-image-proportion 0.9
"How big pictures displayed are in relation to the window they're in.
@ -93,6 +93,12 @@ Alternative suggestions are:
:type 'string
:group 'shr)
(defcustom shr-external-browser 'browse-url-default-browser
"Function used to launch an external browser."
:version "24.4"
:group 'shr
:type 'function)
(defvar shr-content-function nil
"If bound, this should be a function that will return the content.
This is used for cid: URLs, and the function is called with the
@ -138,7 +144,7 @@ cid: URL as the argument.")
(define-key map [backtab] 'shr-previous-link)
(define-key map [follow-link] 'mouse-face)
(define-key map "I" 'shr-insert-image)
(define-key map "u" 'shr-copy-url)
(define-key map "w" 'shr-copy-url)
(define-key map "v" 'shr-browse-url)
(define-key map "o" 'shr-save-contents)
(define-key map "\r" 'shr-browse-url)
@ -160,6 +166,17 @@ cid: URL as the argument.")
(libxml-parse-html-region (point-min) (point-max))))
(goto-char (point-min)))
(defun shr-render-region (begin end &optional buffer)
"Display the HTML rendering of the region between BEGIN and END."
(interactive "r")
(unless (fboundp 'libxml-parse-html-region)
(error "This function requires Emacs to be compiled with libxml2"))
(with-current-buffer (or buffer (current-buffer))
(let ((dom (libxml-parse-html-region begin end)))
(delete-region begin end)
(goto-char begin)
(shr-insert-document dom))))
(defun shr-visit-file (file)
"Parse FILE as an HTML document, and render it in a new buffer."
(interactive "fHTML file name: ")
@ -639,9 +656,10 @@ size, and full-buffer size."
(forward-line 1)
(goto-char end))))))
(defun shr-browse-url ()
"Browse the URL under point."
(interactive)
(defun shr-browse-url (&optional external)
"Browse the URL under point.
If EXTERNAL, browse the URL using `shr-external-browser'."
(interactive "P")
(let ((url (get-text-property (point) 'shr-url)))
(cond
((not url)
@ -649,7 +667,9 @@ size, and full-buffer size."
((string-match "^mailto:" url)
(browse-url-mail url))
(t
(browse-url url)))))
(if external
(funcall shr-external-browser url)
(browse-url url))))))
(defun shr-save-contents (directory)
"Save the contents from URL in a file."
@ -741,34 +761,18 @@ size, and full-buffer size."
(defun shr-rescale-image (data &optional force)
"Rescale DATA, if too big, to fit the current buffer.
If FORCE, rescale the image anyway."
(let ((image (create-image data nil t :ascent 100)))
(if (or (not (fboundp 'imagemagick-types))
(not (get-buffer-window (current-buffer))))
image
(let* ((size (image-size image t))
(width (car size))
(height (cdr size))
(edges (window-inside-pixel-edges
(get-buffer-window (current-buffer))))
(window-width (truncate (* shr-max-image-proportion
(- (nth 2 edges) (nth 0 edges)))))
(window-height (truncate (* shr-max-image-proportion
(- (nth 3 edges) (nth 1 edges)))))
scaled-image)
(when (or force
(> height window-height))
(setq image (or (create-image data 'imagemagick t
:height window-height
:ascent 100)
image))
(setq size (image-size image t)))
(when (> (car size) window-width)
(setq image (or
(create-image data 'imagemagick t
:width window-width
:ascent 100)
image)))
image))))
(if (or (not (fboundp 'imagemagick-types))
(not (get-buffer-window (current-buffer))))
(create-image data nil t :ascent 100)
(let ((edges (window-inside-pixel-edges
(get-buffer-window (current-buffer)))))
(create-image
data 'imagemagick t
:ascent 100
:max-width (truncate (* shr-max-image-proportion
(- (nth 2 edges) (nth 0 edges))))
:max-height (truncate (* shr-max-image-proportion
(- (nth 3 edges) (nth 1 edges))))))))
;; url-cache-extract autoloads url-cache.
(declare-function url-cache-create-filename "url-cache" (url))
@ -1613,27 +1617,6 @@ ones, in case fg and bg are nil."
(shr-count (cdr row) 'th))))))
max))
;; Emacs less than 24.3
(unless (fboundp 'add-face-text-property)
(defun add-face-text-property (beg end face &optional appendp object)
"Combine FACE BEG and END."
(let ((b beg))
(while (< b end)
(let ((oldval (get-text-property b 'face)))
(put-text-property
b (setq b (next-single-property-change b 'face nil end))
'face (cond ((null oldval)
face)
((and (consp oldval)
(not (keywordp (car oldval))))
(if appendp
(nconc oldval (list face))
(cons face oldval)))
(t
(if appendp
(list oldval face)
(list face oldval))))))))))
(provide 'shr)
;; Local Variables:

1
lisp/obsolete/otodo-mode.el
View file

@ -6,6 +6,7 @@
;; Maintainer: Stephen Berman <stephen.berman@gmx.net>
;; Created: 2 Aug 1997
;; Keywords: calendar, todo
;; Obsolete-since: 24.4
;; This file is part of GNU Emacs.

2
lisp/progmodes/ebnf-abn.el
View file

@ -5,7 +5,7 @@
;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Keywords: wp, ebnf, PostScript
;; Version: 1.2
;; Old-Version: 1.2
;; Package: ebnf2ps
;; This file is part of GNU Emacs.

2
lisp/progmodes/ebnf-bnf.el
View file

@ -5,7 +5,7 @@
;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Keywords: wp, ebnf, PostScript
;; Version: 1.10
;; Old-Version: 1.10
;; Package: ebnf2ps
;; This file is part of GNU Emacs.

2
lisp/progmodes/ebnf-dtd.el
View file

@ -5,7 +5,7 @@
;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Keywords: wp, ebnf, PostScript
;; Version: 1.1
;; Old-Version: 1.1
;; Package: ebnf2ps
;; This file is part of GNU Emacs.

2
lisp/progmodes/ebnf-ebx.el
View file

@ -5,7 +5,7 @@
;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Keywords: wp, ebnf, PostScript
;; Version: 1.2
;; Old-Version: 1.2
;; Package: ebnf2ps
;; This file is part of GNU Emacs.

2
lisp/progmodes/ebnf-iso.el
View file

@ -5,7 +5,7 @@
;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Keywords: wp, ebnf, PostScript
;; Version: 1.9
;; Old-Version: 1.9
;; Package: ebnf2ps
;; This file is part of GNU Emacs.

2
lisp/progmodes/ebnf-otz.el
View file

@ -5,7 +5,7 @@
;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Keywords: wp, ebnf, PostScript
;; Version: 1.0
;; Old-Version: 1.0
;; Package: ebnf2ps
;; This file is part of GNU Emacs.

2
lisp/progmodes/ebnf-yac.el
View file

@ -5,7 +5,7 @@
;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Keywords: wp, ebnf, PostScript
;; Version: 1.4
;; Old-Version: 1.4
;; Package: ebnf2ps
;; This file is part of GNU Emacs.

2
lisp/progmodes/idlw-complete-structtag.el
View file

@ -4,7 +4,7 @@
;; Author: Carsten Dominik <dominik@astro.uva.nl>
;; Maintainer: J.D. Smith <jdsmith@as.arizona.edu>
;; Version: 1.2
;; Old-Version: 1.2
;; Keywords: languages
;; Package: idlwave

1
lisp/progmodes/idlw-help.el
View file

@ -5,7 +5,6 @@
;; Authors: J.D. Smith <jdsmith@as.arizona.edu>
;; Carsten Dominik <dominik@science.uva.nl>
;; Maintainer: J.D. Smith <jdsmith@as.arizona.edu>
;; Version: 6.1.22
;; Package: idlwave
;; This file is part of GNU Emacs.

1
lisp/progmodes/idlw-shell.el
View file

@ -6,7 +6,6 @@
;; Carsten Dominik <dominik@astro.uva.nl>
;; Chris Chase <chase@att.com>
;; Maintainer: J.D. Smith <jdsmith@as.arizona.edu>
;; Version: 6.1.22
;; Keywords: processes
;; Package: idlwave

1
lisp/progmodes/idlw-toolbar.el
View file

@ -4,7 +4,6 @@
;; Author: Carsten Dominik <dominik@astro.uva.nl>
;; Maintainer: J.D. Smith <jdsmith@as.arizona.edu>
;; Version: 6.1.22
;; Keywords: processes
;; Package: idlwave

8
lisp/simple.el
View file

@ -6448,10 +6448,10 @@ With a prefix argument, set VARIABLE to VALUE buffer-locally."
(call-interactively `(lambda (arg)
(interactive ,prop)
arg))
(read
(read-string prompt nil
'set-variable-value-history
(format "%S" (symbol-value var))))))))
(read-from-minibuffer prompt nil
read-expression-map t
'set-variable-value-history
(format "%S" (symbol-value var)))))))
(list var val current-prefix-arg)))
(and (custom-variable-p variable)

14
lisp/textmodes/bibtex.el
View file

@ -1224,7 +1224,10 @@ Used by `bibtex-complete-crossref-cleanup' and `bibtex-copy-summary-as-kill'."
(function :tag "Personalized function")))
(defcustom bibtex-generate-url-list
'((("url" . ".*:.*")))
'((("url" . ".*:.*"))
(("doi" . "10\\.[0-9]+/.+")
"http://dx.doi.org/%s"
("doi" ".*" 0)))
"List of schemes for generating the URL of a BibTeX entry.
These schemes are used by `bibtex-url'.
@ -1261,6 +1264,7 @@ The following is a complex example, see URL `http://link.aps.org/'.
(\"volume\" \".*\" 0)
(\"pages\" \"\\`[A-Z]?[0-9]+\" 0)))"
:group 'bibtex
:version "24.4"
:type '(repeat
(cons :tag "Scheme"
(cons :tag "Matcher" :extra-offset 4
@ -3400,9 +3404,6 @@ if that value is non-nil.
(set (make-local-variable 'syntax-propertize-function)
(syntax-propertize-via-font-lock
bibtex-font-lock-syntactic-keywords))
(setq imenu-generic-expression
(list (list nil bibtex-entry-head bibtex-key-in-head))
imenu-case-fold-search t)
;; Allow `bibtex-dialect' as a file-local variable.
(add-hook 'hack-local-variables-hook 'bibtex-set-dialect nil t))
@ -3479,7 +3480,10 @@ LOCAL is t for interactive calls."
(concat "^[ \t]*@[ \t]*\\(?:"
(regexp-opt
(append '("String" "Preamble")
(mapcar 'car bibtex-entry-alist))) "\\)"))))
(mapcar 'car bibtex-entry-alist))) "\\)"))
(setq imenu-generic-expression
(list (list nil bibtex-entry-head bibtex-key-in-head))
imenu-case-fold-search t)))
;; Entry commands and menus for BibTeX dialects
;; We do not use `easy-menu-define' here because this gets confused

6
lisp/url/ChangeLog
View file

@ -1,3 +1,9 @@
2013-06-26 Lars Magne Ingebrigtsen <larsi@gnus.org>
* url-cookie.el: Implement a command and mode for displaying and
editing cookies.
(url-cookie-mode): Fix mode name.
2013-06-21 Glenn Morris <rgm@gnu.org>
* url-future.el (url-future-call): Remove useless value call.

89
lisp/url/url-cookie.el
View file

@ -349,6 +349,95 @@ to run the `url-cookie-setup-save-timer' function manually."
url-cookie-save-interval
#'url-cookie-write-file))))
;;; Mode for listing and editing cookies.
(defun url-cookie-list ()
"List the URL cookies."
(interactive)
(when (and (null url-cookie-secure-storage)
(null url-cookie-storage))
(error "No cookies are defined"))
(pop-to-buffer "*url cookies*")
(let ((inhibit-read-only t)
(domains (sort
(copy-sequence
(append url-cookie-secure-storage
url-cookie-storage))
(lambda (e1 e2)
(string< (car e1) (car e2)))))
(domain-length 0)
start name format domain)
(erase-buffer)
(url-cookie-mode)
(dolist (elem domains)
(setq domain-length (max domain-length (length (car elem)))))
(setq format (format "%%-%ds %%-20s %%s" domain-length)
header-line-format
(concat " " (format format "Domain" "Name" "Value")))
(dolist (elem domains)
(setq domain (car elem))
(dolist (cookie (sort (copy-sequence (cdr elem))
(lambda (c1 c2)
(string< (url-cookie-name c1)
(url-cookie-name c2)))))
(setq start (point)
name (url-cookie-name cookie))
(when (> (length name) 20)
(setq name (substring name 0 20)))
(insert (format format domain name
(url-cookie-value cookie))
"\n")
(setq domain "")
(put-text-property start (1+ start) 'url-cookie cookie)))
(goto-char (point-min))))
(defun url-cookie-delete ()
"Delete the cookie on the current line."
(interactive)
(let ((cookie (get-text-property (line-beginning-position) 'url-cookie))
(inhibit-read-only t)
variable)
(unless cookie
(error "No cookie on the current line"))
(setq variable (if (url-cookie-secure cookie)
'url-cookie-secure-storage
'url-cookie-storage))
(let* ((list (symbol-value variable))
(elem (assoc (url-cookie-domain cookie) list)))
(setq elem (delq cookie elem))
(when (zerop (length (cdr elem)))
(setq list (delq elem list)))
(set variable list))
(setq url-cookies-changed-since-last-save t)
(url-cookie-write-file)
(delete-region (line-beginning-position)
(progn
(forward-line 1)
(point)))))
(defun url-cookie-quit ()
"Kill the current buffer."
(interactive)
(kill-buffer (current-buffer)))
(defvar url-cookie-mode-map
(let ((map (make-sparse-keymap)))
(suppress-keymap map)
(define-key map "q" 'url-cookie-quit)
(define-key map [delete] 'url-cookie-delete)
(define-key map [(control k)] 'url-cookie-delete)
map))
(define-derived-mode url-cookie-mode nil "URL Cookie"
"Mode for listing cookies.
\\{url-cookie-mode-map}"
(buffer-disable-undo)
(setq buffer-read-only t
truncate-lines t))
(provide 'url-cookie)
;;; url-cookie.el ends here

3
lisp/window.el
View file

@ -4258,7 +4258,8 @@ specific buffers."
(total-width . ,(window-total-size window t))
(normal-height . ,(window-normal-size window))
(normal-width . ,(window-normal-size window t))
(combination-limit . ,(window-combination-limit window))
,@(unless (window-live-p window)
`((combination-limit . ,(window-combination-limit window))))
,@(let ((parameters (window-parameters window))
list)
;; Make copies of those window parameters whose

5
nt/ChangeLog
View file

@ -1,3 +1,8 @@
2013-06-25 Juanma Barranquero <lekktu@gmail.com>
* configure.bat: Add warning to the help text about using the
MSYS/MinGW building procedure.
2013-06-07 Eli Zaretskii <eliz@gnu.org>
* INSTALL.MSYS: mingw-get is not a GUI program (yet).

5
nt/configure.bat
View file

@ -174,6 +174,11 @@ echo. Note that this capability of processing parameters that include the =
echo. character depends on command extensions. This batch file attempts to
echo. enable command extensions. If command extensions cannot be enabled, a
echo. warning message will be displayed.
echo.
echo. IMPORTANT: This method of building Emacs for MS-Windows is deprecated,
echo. and could be removed in a future version of Emacs. The preferred way
echo to build Emacs for MS-Windows from now on is using the MSYS environment
echo. and MinGW development tools. Please see nt/INSTALL.MSYS for details.
goto end
rem ----------------------------------------------------------------------

93
src/ChangeLog
View file

@ -17,6 +17,99 @@
:prefer-utf-8.
(syms_of_coding): Adjusted for coding_arg_undecided_max.
2013-06-28 Paul Eggert <eggert@cs.ucla.edu>
* image.c (x_from_xcolors): Remove unused local.
2013-06-28 YAMAMOTO Mitsuharu <mituharu@math.s.chiba-u.ac.jp>
Defer image data transfer between X client and server until actual
display happens.
* dispextern.h (struct image) [HAVE_X_WINDOWS]: New members `ximg'
and `mask_img'.
* image.c (Destroy_Image): Remove.
(x_clear_image_1): New arg `flags' instead of 3 bools `pixmap_p',
`mask_p', and `colors_p'. All uses changed.
(x_clear_image_1) [HAVE_X_WINDOWS]: Destroy `ximg' and `mask_img'.
(CLEAR_IMAGE_PIXMAP, CLEAR_IMAGE_MASK, CLEAR_IMAGE_COLORS): New
macros for `flags' arg to x_clear_image_1.
(postprocess_image, xpm_load_image, x_build_heuristic_mask)
(png_load_body): Use x_clear_image_1 instead of Free_Pixmap.
(ZPixmap, XGetImage) [HAVE_NS]: Remove.
(image_get_x_image_or_dc, image_unget_x_image_or_dc)
(image_get_x_image, image_unget_x_image): New functions or macros.
(image_background, image_background_transparent, x_to_xcolors)
(x_build_heuristic_mask): Use image_get_x_image_or_dc instead of
XGetImage or CreateCompatibleDC. Use image_unget_x_image_or_dc
instead of Destroy_Image.
(image_create_x_image_and_pixmap, image_put_x_image): New functions.
(xpm_load_image, x_from_xcolors, x_build_heuristic_mask, pbm_load)
(png_load_body, jpeg_load_body, tiff_load, gif_load)
(imagemagick_load_image, svg_load_image): Use them instead of
x_create_x_image_and_pixmap, and x_put_x_image followed by
x_destroy_x_image, respectively.
(xpm_load) [HAVE_XPM && !HAVE_NTGUI]: Use XpmReadFileToImage and
XpmCreateImageFromBuffer instead of XpmReadFileToPixmap and
XpmCreatePixmapFromBuffer. Create pixmaps. Fill background and
background_transparent fields.
(image_sync_to_pixmaps) [HAVE_X_WINDOWS]: New function.
(prepare_image_for_display, x_disable_image) [HAVE_X_WINDOWS]: Use it.
2013-06-27 Paul Eggert <eggert@cs.ucla.edu>
Do not tickle glib SIGCHLD handling if Cygwin (Bug#14569).
This mostly consists of undoing recent changes.
* callproc.c (Fcall_process):
* process.c (create_process):
Do not worry about catching SIGCHLD here, undoing previous change.
* nsterm.m (ns_term_init): Re-catch SIGCHLD, undoing previous change.
* process.c, process.h (catch_child_signal):
No longer extern if !NS_IMPL_GNUSTEP, undoing 06-22 change.
* process.c (catch_child_handler): Don't worry about being called
lazily and do not assume caller has blocked SIGCHLD, undoing
previous change. Move first-time stuff back to
init_process_emacs, undoing 06-22 change. If CYGWIN, do not
tickle glib, as that causes Cygwin bootstrap to fail. Do not
set lib_child_handler if it's already initialized, which may
help avoid problems on GNUStep.
2013-06-23 Paul Eggert <eggert@cs.ucla.edu>
A more-conservative workaround for Cygwin SIGCHLD issues (Bug#14569).
* callproc.c (Fcall_process):
* process.c (create_process):
Make sure SIGCHLD is caught before we fork,
since Emacs startup no arranges to catch SIGCHLD.
* process.c (lib_child_handler): Initialize to null, not to
dummy_handler.
(catch_child_signal): Allow self to be called lazily.
Do nothing if it's already been called.
Assume caller has blocked SIGCHLD (all callers do now).
* emacs.c (main): Do not catch SIGCHLD here; defer it until
just before it's really needed.
* nsterm.m (ns_term_init): No need to re-catch SIGCHLD here,
since it hasn't been caught yet.
2013-06-23 Lars Magne Ingebrigtsen <larsi@gnus.org>
* image.c (compute_image_size): New function to implement
:max-width and :max-height.
(imagemagick_load_image): Use it.
2013-06-23 Paul Eggert <eggert@cs.ucla.edu>
Try to avoid malloc SEGVs on Cygwin (Bug#14569).
* callproc.c, process.h (block_child_signal, unblock_child_signal):
Now extern.
* emacs.c (main): Catch SIGCHLD just before initializing gfilenotify.
* process.c (catch_child_signal): Block SIGCHLD while futzing with
the SIGCHLD handler, since the code is not atomic and (due to glib)
signals may be arriving now.
* sysdep.c (init_signals): Do not catch child signals here;
'main' now does that later, at a safer time.
2013-06-22 Paul Eggert <eggert@cs.ucla.edu>
Clean up SIGCHLD handling a bit (Bug#14569).

4
src/callproc.c
View file

@ -84,7 +84,7 @@ static int synch_process_fd;
/* Block SIGCHLD. */
static void
void
block_child_signal (void)
{
sigset_t blocked;
@ -95,7 +95,7 @@ block_child_signal (void)
/* Unblock SIGCHLD. */
static void
void
unblock_child_signal (void)
{
pthread_sigmask (SIG_SETMASK, &empty_mask, 0);

8
src/dispextern.h
View file

@ -2870,6 +2870,14 @@ struct image
/* Pixmaps of the image. */
Pixmap pixmap, mask;
#ifdef HAVE_X_WINDOWS
/* X images of the image, corresponding to the above Pixmaps.
Non-NULL means it and its Pixmap counterpart may be out of sync
and the latter is outdated. NULL means the X image has been
synchronized to Pixmap. */
XImagePtr ximg, mask_img;
#endif
/* Colors allocated for this image, if any. Allocated via xmalloc. */
unsigned long *colors;
int ncolors;

561
src/image.c
View file

@ -106,8 +106,6 @@ typedef struct ns_bitmap_record Bitmap_Record;
#define GET_PIXEL(ximg, x, y) XGetPixel (ximg, x, y)
#define NO_PIXMAP 0
#define ZPixmap 0
#define PIX_MASK_RETAIN 0
#define PIX_MASK_DRAW 1
@ -132,6 +130,8 @@ static void free_color_table (void);
static unsigned long *colors_in_color_table (int *n);
#endif
Lisp_Object QCmax_width, QCmax_height;
/* Code to deal with bitmaps. Bitmaps are referenced by their bitmap
id, which is just an int that this section returns. Bitmaps are
reference counted so they can be shared among frames.
@ -144,16 +144,6 @@ static unsigned long *colors_in_color_table (int *n);
data more than once will not be caught. */
#ifdef HAVE_NS
XImagePtr
XGetImage (Display *display, Pixmap pixmap, int x, int y,
unsigned int width, unsigned int height,
unsigned long plane_mask, int format)
{
/* TODO: not sure what this function is supposed to do.. */
ns_retain_object (pixmap);
return pixmap;
}
/* Use with images created by ns_image_for_XPM. */
unsigned long
XGetPixel (XImagePtr ximage, int x, int y)
@ -433,8 +423,24 @@ static bool x_create_x_image_and_pixmap (struct frame *, int, int, int,
XImagePtr *, Pixmap *);
static void x_destroy_x_image (XImagePtr ximg);
#ifdef HAVE_NTGUI
static XImagePtr_or_DC image_get_x_image_or_dc (struct frame *, struct image *,
bool, HGDIOBJ *);
static void image_unget_x_image_or_dc (struct image *, bool, XImagePtr_or_DC,
HGDIOBJ);
#else
static XImagePtr image_get_x_image (struct frame *, struct image *, bool);
static void image_unget_x_image (struct image *, bool, XImagePtr);
#define image_get_x_image_or_dc(f, img, mask_p, dummy) \
image_get_x_image (f, img, mask_p)
#define image_unget_x_image_or_dc(img, mask_p, ximg, dummy) \
image_unget_x_image (img, mask_p, ximg)
#endif
#ifdef HAVE_X_WINDOWS
static void image_sync_to_pixmaps (struct frame *, struct image *);
/* Useful functions defined in the section
`Image type independent image structures' below. */
@ -1048,6 +1054,14 @@ prepare_image_for_display (struct frame *f, struct image *img)
if (img->pixmap == NO_PIXMAP && !img->load_failed_p)
img->load_failed_p = ! img->type->load (f, img);
#ifdef HAVE_X_WINDOWS
if (!img->load_failed_p)
{
block_input ();
image_sync_to_pixmaps (f, img);
unblock_input ();
}
#endif
}
@ -1143,25 +1157,16 @@ four_corners_best (XImagePtr_or_DC ximg, int *corners,
#ifdef HAVE_NTGUI
#define Destroy_Image(img_dc, prev) \
do { SelectObject (img_dc, prev); DeleteDC (img_dc); } while (0)
#define Free_Pixmap(display, pixmap) \
DeleteObject (pixmap)
#elif defined (HAVE_NS)
#define Destroy_Image(ximg, dummy) \
ns_release_object (ximg)
#define Free_Pixmap(display, pixmap) \
ns_release_object (pixmap)
#else
#define Destroy_Image(ximg, dummy) \
XDestroyImage (ximg)
#define Free_Pixmap(display, pixmap) \
XFreePixmap (display, pixmap)
@ -1185,22 +1190,12 @@ image_background (struct image *img, struct frame *f, XImagePtr_or_DC ximg)
#endif /* HAVE_NTGUI */
if (free_ximg)
{
#ifndef HAVE_NTGUI
ximg = XGetImage (FRAME_X_DISPLAY (f), img->pixmap,
0, 0, img->width, img->height, ~0, ZPixmap);
#else
HDC frame_dc = get_frame_dc (f);
ximg = CreateCompatibleDC (frame_dc);
release_frame_dc (f, frame_dc);
prev = SelectObject (ximg, img->pixmap);
#endif /* !HAVE_NTGUI */
}
ximg = image_get_x_image_or_dc (f, img, 0, &prev);
img->background = four_corners_best (ximg, img->corners, img->width, img->height);
if (free_ximg)
Destroy_Image (ximg, prev);
image_unget_x_image_or_dc (img, 0, ximg, prev);
img->background_valid = 1;
}
@ -1226,23 +1221,13 @@ image_background_transparent (struct image *img, struct frame *f, XImagePtr_or_D
#endif /* HAVE_NTGUI */
if (free_mask)
{
#ifndef HAVE_NTGUI
mask = XGetImage (FRAME_X_DISPLAY (f), img->mask,
0, 0, img->width, img->height, ~0, ZPixmap);
#else
HDC frame_dc = get_frame_dc (f);
mask = CreateCompatibleDC (frame_dc);
release_frame_dc (f, frame_dc);
prev = SelectObject (mask, img->mask);
#endif /* HAVE_NTGUI */
}
mask = image_get_x_image_or_dc (f, img, 1, &prev);
img->background_transparent
= (four_corners_best (mask, img->corners, img->width, img->height) == PIX_MASK_RETAIN);
if (free_mask)
Destroy_Image (mask, prev);
image_unget_x_image_or_dc (img, 1, mask, prev);
}
else
img->background_transparent = 0;
@ -1258,30 +1243,58 @@ image_background_transparent (struct image *img, struct frame *f, XImagePtr_or_D
Helper functions for X image types
***********************************************************************/
/* Clear X resources of image IMG on frame F. PIXMAP_P means free the
pixmap if any. MASK_P means clear the mask pixmap if any.
COLORS_P means free colors allocated for the image, if any. */
/* Clear X resources of image IMG on frame F according to FLAGS.
FLAGS is bitwise-or of the following masks:
CLEAR_IMAGE_PIXMAP free the pixmap if any.
CLEAR_IMAGE_MASK means clear the mask pixmap if any.
CLEAR_IMAGE_COLORS means free colors allocated for the image, if
any. */
#define CLEAR_IMAGE_PIXMAP (1 << 0)
#define CLEAR_IMAGE_MASK (1 << 1)
#define CLEAR_IMAGE_COLORS (1 << 2)
static void
x_clear_image_1 (struct frame *f, struct image *img, bool pixmap_p,
bool mask_p, bool colors_p)
x_clear_image_1 (struct frame *f, struct image *img, int flags)
{
if (pixmap_p && img->pixmap)
if (flags & CLEAR_IMAGE_PIXMAP)
{
Free_Pixmap (FRAME_X_DISPLAY (f), img->pixmap);
img->pixmap = NO_PIXMAP;
/* NOTE (HAVE_NS): background color is NOT an indexed color! */
img->background_valid = 0;
if (img->pixmap)
{
Free_Pixmap (FRAME_X_DISPLAY (f), img->pixmap);
img->pixmap = NO_PIXMAP;
/* NOTE (HAVE_NS): background color is NOT an indexed color! */
img->background_valid = 0;
}
#ifdef HAVE_X_WINDOWS
if (img->ximg)
{
x_destroy_x_image (img->ximg);
img->ximg = NULL;
img->background_valid = 0;
}
#endif
}
if (mask_p && img->mask)
if (flags & CLEAR_IMAGE_MASK)
{
Free_Pixmap (FRAME_X_DISPLAY (f), img->mask);
img->mask = NO_PIXMAP;
img->background_transparent_valid = 0;
if (img->mask)
{
Free_Pixmap (FRAME_X_DISPLAY (f), img->mask);
img->mask = NO_PIXMAP;
img->background_transparent_valid = 0;
}
#ifdef HAVE_X_WINDOWS
if (img->mask_img)
{
x_destroy_x_image (img->mask_img);
img->mask_img = NULL;
img->background_transparent_valid = 0;
}
#endif
}
if (colors_p && img->ncolors)
if ((flags & CLEAR_IMAGE_COLORS) && img->ncolors)
{
/* W32_TODO: color table support. */
#ifdef HAVE_X_WINDOWS
@ -1300,7 +1313,8 @@ static void
x_clear_image (struct frame *f, struct image *img)
{
block_input ();
x_clear_image_1 (f, img, 1, 1, 1);
x_clear_image_1 (f, img,
CLEAR_IMAGE_PIXMAP | CLEAR_IMAGE_MASK | CLEAR_IMAGE_COLORS);
unblock_input ();
}
@ -1631,10 +1645,7 @@ postprocess_image (struct frame *f, struct image *img)
x_build_heuristic_mask (f, img, XCDR (mask));
}
else if (NILP (mask) && found_p && img->mask)
{
Free_Pixmap (FRAME_X_DISPLAY (f), img->mask);
img->mask = NO_PIXMAP;
}
x_clear_image_1 (f, img, CLEAR_IMAGE_MASK);
}
@ -2092,6 +2103,133 @@ x_put_x_image (struct frame *f, XImagePtr ximg, Pixmap pixmap, int width, int he
#endif
}
/* Thin wrapper for x_create_x_image_and_pixmap, so that it matches
with image_put_x_image. */
static bool
image_create_x_image_and_pixmap (struct frame *f, struct image *img,
int width, int height, int depth,
XImagePtr *ximg, bool mask_p)
{
eassert ((!mask_p ? img->pixmap : img->mask) == NO_PIXMAP);
return x_create_x_image_and_pixmap (f, width, height, depth, ximg,
!mask_p ? &img->pixmap : &img->mask);
}
/* Put X image XIMG into image IMG on frame F, as a mask if and only
if MASK_P. On X, this simply records XIMG on a member of IMG, so
it can be put into the pixmap afterwards via image_sync_to_pixmaps.
On the other platforms, it puts XIMG into the pixmap, then frees
the X image and its buffer. */
static void
image_put_x_image (struct frame *f, struct image *img, XImagePtr ximg,
bool mask_p)
{
#ifdef HAVE_X_WINDOWS
if (!mask_p)
{
eassert (img->ximg == NULL);
img->ximg = ximg;
}
else
{
eassert (img->mask_img == NULL);
img->mask_img = ximg;
}
#else
x_put_x_image (f, ximg, !mask_p ? img->pixmap : img->mask,
img->width, img->height);
x_destroy_x_image (ximg);
#endif
}
#ifdef HAVE_X_WINDOWS
/* Put the X images recorded in IMG on frame F into pixmaps, then free
the X images and their buffers. */
static void
image_sync_to_pixmaps (struct frame *f, struct image *img)
{
if (img->ximg)
{
x_put_x_image (f, img->ximg, img->pixmap, img->width, img->height);
x_destroy_x_image (img->ximg);
img->ximg = NULL;
}
if (img->mask_img)
{
x_put_x_image (f, img->mask_img, img->mask, img->width, img->height);
x_destroy_x_image (img->mask_img);
img->mask_img = NULL;
}
}
#endif
#ifdef HAVE_NTGUI
/* Create a memory device context for IMG on frame F. It stores the
currently selected GDI object into *PREV for future restoration by
image_unget_x_image_or_dc. */
static XImagePtr_or_DC
image_get_x_image_or_dc (struct frame *f, struct image *img, bool mask_p,
HGDIOBJ *prev)
{
HDC frame_dc = get_frame_dc (f);
XImagePtr_or_DC ximg = CreateCompatibleDC (frame_dc);
release_frame_dc (f, frame_dc);
*prev = SelectObject (ximg, !mask_p ? img->pixmap : img->mask);
return ximg;
}
static void
image_unget_x_image_or_dc (struct image *img, bool mask_p,
XImagePtr_or_DC ximg, HGDIOBJ prev)
{
SelectObject (ximg, prev);
DeleteDC (ximg);
}
#else /* !HAVE_NTGUI */
/* Get the X image for IMG on frame F. The resulting X image data
should be treated as read-only at least on X. */
static XImagePtr
image_get_x_image (struct frame *f, struct image *img, bool mask_p)
{
#ifdef HAVE_X_WINDOWS
XImagePtr ximg_in_img = !mask_p ? img->ximg : img->mask_img;
if (ximg_in_img)
return ximg_in_img;
else
return XGetImage (FRAME_X_DISPLAY (f), !mask_p ? img->pixmap : img->mask,
0, 0, img->width, img->height, ~0, ZPixmap);
#elif defined (HAVE_NS)
XImagePtr pixmap = !mask_p ? img->pixmap : img->mask;
ns_retain_object (pixmap);
return pixmap;
#endif
}
static void image_unget_x_image (struct image *img, bool mask_p, XImagePtr ximg)
{
#ifdef HAVE_X_WINDOWS
XImagePtr ximg_in_img = !mask_p ? img->ximg : img->mask_img;
if (ximg_in_img)
eassert (ximg == ximg_in_img);
else
XDestroyImage (ximg);
#elif defined (HAVE_NS)
ns_release_object (ximg);
#endif
}
#endif /* !HAVE_NTGUI */
/***********************************************************************
File Handling
@ -3459,9 +3597,9 @@ xpm_load (struct frame *f, struct image *img)
&xpm_image, &xpm_mask,
&attrs);
#else
rc = XpmReadFileToPixmap (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f),
SSDATA (file), &img->pixmap, &img->mask,
&attrs);
rc = XpmReadFileToImage (FRAME_X_DISPLAY (f), SSDATA (file),
&img->ximg, &img->mask_img,
&attrs);
#endif /* HAVE_NTGUI */
}
else
@ -3482,13 +3620,38 @@ xpm_load (struct frame *f, struct image *img)
&xpm_image, &xpm_mask,
&attrs);
#else
rc = XpmCreatePixmapFromBuffer (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f),
SSDATA (buffer),
&img->pixmap, &img->mask,
&attrs);
rc = XpmCreateImageFromBuffer (FRAME_X_DISPLAY (f), SSDATA (buffer),
&img->ximg, &img->mask_img,
&attrs);
#endif /* HAVE_NTGUI */
}
#ifdef HAVE_X_WINDOWS
if (rc == XpmSuccess)
{
img->pixmap = XCreatePixmap (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f),
img->ximg->width, img->ximg->height,
img->ximg->depth);
if (img->pixmap == NO_PIXMAP)
{
x_clear_image (f, img);
rc = XpmNoMemory;
}
else if (img->mask_img)
{
img->mask = XCreatePixmap (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f),
img->mask_img->width,
img->mask_img->height,
img->mask_img->depth);
if (img->mask == NO_PIXMAP)
{
x_clear_image (f, img);
rc = XpmNoMemory;
}
}
}
#endif
if (rc == XpmSuccess)
{
#if defined (COLOR_TABLE_SUPPORT) && defined (ALLOC_XPM_COLORS)
@ -3547,6 +3710,15 @@ xpm_load (struct frame *f, struct image *img)
#else
XpmFreeAttributes (&attrs);
#endif /* HAVE_NTGUI */
#ifdef HAVE_X_WINDOWS
/* Maybe fill in the background field while we have ximg handy. */
IMAGE_BACKGROUND (img, f, img->ximg);
if (img->mask_img)
/* Fill in the background_transparent field while we have the
mask handy. */
image_background_transparent (img, f, img->mask_img);
#endif
}
else
{
@ -3845,11 +4017,10 @@ xpm_load_image (struct frame *f,
goto failure;
}
if (!x_create_x_image_and_pixmap (f, width, height, 0,
&ximg, &img->pixmap)
if (!image_create_x_image_and_pixmap (f, img, width, height, 0, &ximg, 0)
#ifndef HAVE_NS
|| !x_create_x_image_and_pixmap (f, width, height, 1,
&mask_img, &img->mask)
|| !image_create_x_image_and_pixmap (f, img, width, height, 1,
&mask_img, 1)
#endif
)
{
@ -3984,8 +4155,7 @@ xpm_load_image (struct frame *f,
if (NILP (image_spec_value (img->spec, QCbackground, NULL)))
IMAGE_BACKGROUND (img, f, ximg);
x_put_x_image (f, ximg, img->pixmap, width, height);
x_destroy_x_image (ximg);
image_put_x_image (f, img, ximg, 0);
#ifndef HAVE_NS
if (have_mask)
{
@ -3993,14 +4163,12 @@ xpm_load_image (struct frame *f,
mask handy. */
image_background_transparent (img, f, mask_img);
x_put_x_image (f, mask_img, img->mask, width, height);
x_destroy_x_image (mask_img);
image_put_x_image (f, img, mask_img, 1);
}
else
{
x_destroy_x_image (mask_img);
Free_Pixmap (FRAME_X_DISPLAY (f), img->mask);
img->mask = NO_PIXMAP;
x_clear_image_1 (f, img, CLEAR_IMAGE_MASK);
}
#endif
return 1;
@ -4398,17 +4566,8 @@ x_to_xcolors (struct frame *f, struct image *img, bool rgb_p)
memory_full (SIZE_MAX);
colors = xmalloc (sizeof *colors * img->width * img->height);
#ifndef HAVE_NTGUI
/* Get the X image IMG->pixmap. */
ximg = XGetImage (FRAME_X_DISPLAY (f), img->pixmap,
0, 0, img->width, img->height, ~0, ZPixmap);
#else
/* Load the image into a memory device context. */
hdc = get_frame_dc (f);
ximg = CreateCompatibleDC (hdc);
release_frame_dc (f, hdc);
prev = SelectObject (ximg, img->pixmap);
#endif /* HAVE_NTGUI */
/* Get the X image or create a memory device context for IMG. */
ximg = image_get_x_image_or_dc (f, img, 0, &prev);
/* Fill the `pixel' members of the XColor array. I wished there
were an easy and portable way to circumvent XGetPixel. */
@ -4438,7 +4597,7 @@ x_to_xcolors (struct frame *f, struct image *img, bool rgb_p)
#endif /* HAVE_X_WINDOWS */
}
Destroy_Image (ximg, prev);
image_unget_x_image_or_dc (img, 0, ximg, prev);
return colors;
}
@ -4498,13 +4657,13 @@ x_from_xcolors (struct frame *f, struct image *img, XColor *colors)
{
int x, y;
XImagePtr oimg = NULL;
Pixmap pixmap;
XColor *p;
init_color_table ();
x_create_x_image_and_pixmap (f, img->width, img->height, 0,
&oimg, &pixmap);
x_clear_image_1 (f, img, CLEAR_IMAGE_PIXMAP | CLEAR_IMAGE_COLORS);
image_create_x_image_and_pixmap (f, img, img->width, img->height, 0,
&oimg, 0);
p = colors;
for (y = 0; y < img->height; ++y)
for (x = 0; x < img->width; ++x, ++p)
@ -4515,11 +4674,8 @@ x_from_xcolors (struct frame *f, struct image *img, XColor *colors)
}
xfree (colors);
x_clear_image_1 (f, img, 1, 0, 1);
x_put_x_image (f, oimg, pixmap, img->width, img->height);
x_destroy_x_image (oimg);
img->pixmap = pixmap;
image_put_x_image (f, img, oimg, 0);
#ifdef COLOR_TABLE_SUPPORT
img->colors = colors_in_color_table (&img->ncolors);
free_color_table ();
@ -4704,7 +4860,10 @@ x_disable_image (struct frame *f, struct image *img)
#define MaskForeground(f) WHITE_PIX_DEFAULT (f)
Display *dpy = FRAME_X_DISPLAY (f);
GC gc = XCreateGC (dpy, img->pixmap, 0, NULL);
GC gc;
image_sync_to_pixmaps (f, img);
gc = XCreateGC (dpy, img->pixmap, 0, NULL);
XSetForeground (dpy, gc, BLACK_PIX_DEFAULT (f));
XDrawLine (dpy, img->pixmap, gc, 0, 0,
img->width - 1, img->height - 1);
@ -4779,37 +4938,25 @@ x_build_heuristic_mask (struct frame *f, struct image *img, Lisp_Object how)
unsigned long bg = 0;
if (img->mask)
{
Free_Pixmap (FRAME_X_DISPLAY (f), img->mask);
img->mask = NO_PIXMAP;
img->background_transparent_valid = 0;
}
x_clear_image_1 (f, img, CLEAR_IMAGE_MASK);
#ifndef HAVE_NTGUI
#ifndef HAVE_NS
/* Create an image and pixmap serving as mask. */
rc = x_create_x_image_and_pixmap (f, img->width, img->height, 1,
&mask_img, &img->mask);
rc = image_create_x_image_and_pixmap (f, img, img->width, img->height, 1,
&mask_img, 1);
if (!rc)
return;
#endif /* !HAVE_NS */
/* Get the X image of IMG->pixmap. */
ximg = XGetImage (FRAME_X_DISPLAY (f), img->pixmap, 0, 0,
img->width, img->height,
~0, ZPixmap);
#else
/* Create the bit array serving as mask. */
row_width = (img->width + 7) / 8;
mask_img = xzalloc (row_width * img->height);
/* Create a memory device context for IMG->pixmap. */
frame_dc = get_frame_dc (f);
ximg = CreateCompatibleDC (frame_dc);
release_frame_dc (f, frame_dc);
prev = SelectObject (ximg, img->pixmap);
#endif /* HAVE_NTGUI */
/* Get the X image or create a memory device context for IMG. */
ximg = image_get_x_image_or_dc (f, img, 0, &prev);
/* Determine the background color of ximg. If HOW is `(R G B)'
take that as color. Otherwise, use the image's background color. */
use_img_background = 1;
@ -4856,9 +5003,8 @@ x_build_heuristic_mask (struct frame *f, struct image *img, Lisp_Object how)
/* Fill in the background_transparent field while we have the mask handy. */
image_background_transparent (img, f, mask_img);
/* Put mask_img into img->mask. */
x_put_x_image (f, mask_img, img->mask, img->width, img->height);
x_destroy_x_image (mask_img);
/* Put mask_img into the image. */
image_put_x_image (f, img, mask_img, 1);
#endif /* !HAVE_NS */
#else
for (y = 0; y < img->height; ++y)
@ -4880,7 +5026,7 @@ x_build_heuristic_mask (struct frame *f, struct image *img, Lisp_Object how)
xfree (mask_img);
#endif /* HAVE_NTGUI */
Destroy_Image (ximg, prev);
image_unget_x_image_or_dc (img, 0, ximg, prev);
}
@ -5108,8 +5254,7 @@ pbm_load (struct frame *f, struct image *img)
goto error;
}
if (!x_create_x_image_and_pixmap (f, width, height, 0,
&ximg, &img->pixmap))
if (!image_create_x_image_and_pixmap (f, img, width, height, 0, &ximg, 0))
goto error;
/* Initialize the color hash table. */
@ -5246,9 +5391,8 @@ pbm_load (struct frame *f, struct image *img)
/* Casting avoids a GCC warning. */
IMAGE_BACKGROUND (img, f, (XImagePtr_or_DC)ximg);
/* Put the image into a pixmap. */
x_put_x_image (f, ximg, img->pixmap, width, height);
x_destroy_x_image (ximg);
/* Put ximg into the image. */
image_put_x_image (f, img, ximg, 0);
/* X and W32 versions did it here, MAC version above. ++kfs
img->width = width;
@ -5686,8 +5830,7 @@ png_load_body (struct frame *f, struct image *img, struct png_load_context *c)
/* Create the X image and pixmap now, so that the work below can be
omitted if the image is too large for X. */
if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg,
&img->pixmap))
if (!image_create_x_image_and_pixmap (f, img, width, height, 0, &ximg, 0))
goto error;
/* If image contains simply transparency data, we prefer to
@ -5799,12 +5942,11 @@ png_load_body (struct frame *f, struct image *img, struct png_load_context *c)
contains an alpha channel. */
if (channels == 4
&& !transparent_p
&& !x_create_x_image_and_pixmap (f, width, height, 1,
&mask_img, &img->mask))
&& !image_create_x_image_and_pixmap (f, img, width, height, 1,
&mask_img, 1))
{
x_destroy_x_image (ximg);
Free_Pixmap (FRAME_X_DISPLAY (f), img->pixmap);
img->pixmap = NO_PIXMAP;
x_clear_image_1 (f, img, CLEAR_IMAGE_PIXMAP);
goto error;
}
@ -5878,9 +6020,8 @@ png_load_body (struct frame *f, struct image *img, struct png_load_context *c)
Casting avoids a GCC warning. */
IMAGE_BACKGROUND (img, f, (XImagePtr_or_DC)ximg);
/* Put the image into the pixmap, then free the X image and its buffer. */
x_put_x_image (f, ximg, img->pixmap, width, height);
x_destroy_x_image (ximg);
/* Put ximg into the image. */
image_put_x_image (f, img, ximg, 0);
/* Same for the mask. */
if (mask_img)
@ -5889,8 +6030,7 @@ png_load_body (struct frame *f, struct image *img, struct png_load_context *c)
mask handy. Casting avoids a GCC warning. */
image_background_transparent (img, f, (XImagePtr_or_DC)mask_img);
x_put_x_image (f, mask_img, img->mask, img->width, img->height);
x_destroy_x_image (mask_img);
image_put_x_image (f, img, mask_img, 1);
}
return 1;
@ -6427,7 +6567,7 @@ jpeg_load_body (struct frame *f, struct image *img,
}
/* Create X image and pixmap. */
if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg, &img->pixmap))
if (!image_create_x_image_and_pixmap (f, img, width, height, 0, &ximg, 0))
{
mgr->failure_code = MY_JPEG_CANNOT_CREATE_X;
sys_longjmp (mgr->setjmp_buffer, 1);
@ -6494,9 +6634,8 @@ jpeg_load_body (struct frame *f, struct image *img,
/* Casting avoids a GCC warning. */
IMAGE_BACKGROUND (img, f, (XImagePtr_or_DC)ximg);
/* Put the image into the pixmap. */
x_put_x_image (f, ximg, img->pixmap, width, height);
x_destroy_x_image (ximg);
/* Put ximg into the image. */
image_put_x_image (f, img, ximg, 0);
return 1;
}
@ -6893,8 +7032,8 @@ tiff_load (struct frame *f, struct image *img)
/* Create the X image and pixmap. */
if (! (height <= min (PTRDIFF_MAX, SIZE_MAX) / sizeof *buf / width
&& x_create_x_image_and_pixmap (f, width, height, 0,
&ximg, &img->pixmap)))
&& image_create_x_image_and_pixmap (f, img, width, height, 0,
&ximg, 0)))
{
fn_TIFFClose (tiff);
return 0;
@ -6953,9 +7092,8 @@ tiff_load (struct frame *f, struct image *img)
/* Casting avoids a GCC warning on W32. */
IMAGE_BACKGROUND (img, f, (XImagePtr_or_DC)ximg);
/* Put the image into the pixmap, then free the X image and its buffer. */
x_put_x_image (f, ximg, img->pixmap, width, height);
x_destroy_x_image (ximg);
/* Put ximg into the image. */
image_put_x_image (f, img, ximg, 0);
xfree (buf);
return 1;
@ -7283,7 +7421,7 @@ gif_load (struct frame *f, struct image *img)
}
/* Create the X image and pixmap. */
if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg, &img->pixmap))
if (!image_create_x_image_and_pixmap (f, img, width, height, 0, &ximg, 0))
{
fn_DGifCloseFile (gif);
return 0;
@ -7467,9 +7605,8 @@ gif_load (struct frame *f, struct image *img)
/* Casting avoids a GCC warning. */
IMAGE_BACKGROUND (img, f, (XImagePtr_or_DC)ximg);
/* Put the image into the pixmap, then free the X image and its buffer. */
x_put_x_image (f, ximg, img->pixmap, width, height);
x_destroy_x_image (ximg);
/* Put ximg into the image. */
image_put_x_image (f, img, ximg, 0);
return 1;
}
@ -7489,6 +7626,76 @@ gif_load (struct frame *f, struct image *img)
#endif /* HAVE_GIF */
static void
compute_image_size (size_t width, size_t height,
Lisp_Object spec,
int *d_width, int *d_height)
{
Lisp_Object value;
int desired_width, desired_height;
/* If width and/or height is set in the display spec assume we want
to scale to those values. If either h or w is unspecified, the
unspecified should be calculated from the specified to preserve
aspect ratio. */
value = image_spec_value (spec, QCwidth, NULL);
desired_width = (INTEGERP (value) ? XFASTINT (value) : -1);
value = image_spec_value (spec, QCheight, NULL);
desired_height = (INTEGERP (value) ? XFASTINT (value) : -1);
if (desired_width == -1)
{
value = image_spec_value (spec, QCmax_width, NULL);
if (INTEGERP (value) &&
width > XFASTINT (value))
{
/* The image is wider than :max-width. */
desired_width = XFASTINT (value);
if (desired_height == -1)
{
value = image_spec_value (spec, QCmax_height, NULL);
if (INTEGERP (value))
{
/* We have no specified height, but we have a
:max-height value, so check that we satisfy both
conditions. */
desired_height = (double) desired_width / width * height;
if (desired_height > XFASTINT (value))
{
desired_height = XFASTINT (value);
desired_width = (double) desired_height / height * width;
}
}
else
{
/* We have no specified height and no specified
max-height, so just compute the height. */
desired_height = (double) desired_width / width * height;
}
}
}
}
if (desired_height == -1)
{
value = image_spec_value (spec, QCmax_height, NULL);
if (INTEGERP (value) &&
height > XFASTINT (value))
desired_height = XFASTINT (value);
}
if (desired_width != -1 && desired_height == -1)
/* w known, calculate h. */
desired_height = (double) desired_width / width * height;
if (desired_width == -1 && desired_height != -1)
/* h known, calculate w. */
desired_width = (double) desired_height / height * width;
*d_width = desired_width;
*d_height = desired_height;
}
/***********************************************************************
ImageMagick
***********************************************************************/
@ -7516,6 +7723,8 @@ enum imagemagick_keyword_index
IMAGEMAGICK_BACKGROUND,
IMAGEMAGICK_HEIGHT,
IMAGEMAGICK_WIDTH,
IMAGEMAGICK_MAX_HEIGHT,
IMAGEMAGICK_MAX_WIDTH,
IMAGEMAGICK_ROTATION,
IMAGEMAGICK_CROP,
IMAGEMAGICK_LAST
@ -7538,6 +7747,8 @@ static struct image_keyword imagemagick_format[IMAGEMAGICK_LAST] =
{":background", IMAGE_STRING_OR_NIL_VALUE, 0},
{":height", IMAGE_INTEGER_VALUE, 0},
{":width", IMAGE_INTEGER_VALUE, 0},
{":max-height", IMAGE_INTEGER_VALUE, 0},
{":max-width", IMAGE_INTEGER_VALUE, 0},
{":rotation", IMAGE_NUMBER_VALUE, 0},
{":crop", IMAGE_DONT_CHECK_VALUE_TYPE, 0}
};
@ -7726,24 +7937,10 @@ imagemagick_load_image (struct frame *f, struct image *img,
PixelSetBlue (bg_wand, (double) bgcolor.blue / 65535);
}
/* If width and/or height is set in the display spec assume we want
to scale to those values. If either h or w is unspecified, the
unspecified should be calculated from the specified to preserve
aspect ratio. */
value = image_spec_value (img->spec, QCwidth, NULL);
desired_width = (INTEGERP (value) ? XFASTINT (value) : -1);
value = image_spec_value (img->spec, QCheight, NULL);
desired_height = (INTEGERP (value) ? XFASTINT (value) : -1);
compute_image_size (MagickGetImageWidth (image_wand),
MagickGetImageHeight (image_wand),
img->spec, &desired_width, &desired_height);
height = MagickGetImageHeight (image_wand);
width = MagickGetImageWidth (image_wand);
if (desired_width != -1 && desired_height == -1)
/* w known, calculate h. */
desired_height = (double) desired_width / width * height;
if (desired_width == -1 && desired_height != -1)
/* h known, calculate w. */
desired_width = (double) desired_height / height * width;
if (desired_width != -1 && desired_height != -1)
{
status = MagickScaleImage (image_wand, desired_width, desired_height);
@ -7847,8 +8044,8 @@ imagemagick_load_image (struct frame *f, struct image *img,
int imagedepth = 24; /*MagickGetImageDepth(image_wand);*/
const char *exportdepth = imagedepth <= 8 ? "I" : "BGRP"; /*"RGBP";*/
/* Try to create a x pixmap to hold the imagemagick pixmap. */
if (!x_create_x_image_and_pixmap (f, width, height, imagedepth,
&ximg, &img->pixmap))
if (!image_create_x_image_and_pixmap (f, img, width, height, imagedepth,
&ximg, 0))
{
#ifdef COLOR_TABLE_SUPPORT
free_color_table ();
@ -7886,8 +8083,8 @@ imagemagick_load_image (struct frame *f, struct image *img,
size_t image_height;
/* Try to create a x pixmap to hold the imagemagick pixmap. */
if (!x_create_x_image_and_pixmap (f, width, height, 0,
&ximg, &img->pixmap))
if (!image_create_x_image_and_pixmap (f, img, width, height, 0,
&ximg, 0))
{
#ifdef COLOR_TABLE_SUPPORT
free_color_table ();
@ -7941,10 +8138,8 @@ imagemagick_load_image (struct frame *f, struct image *img,
img->width = width;
img->height = height;
/* Put the image into the pixmap, then free the X image and its
buffer. */
x_put_x_image (f, ximg, img->pixmap, width, height);
x_destroy_x_image (ximg);
/* Put ximg into the image. */
image_put_x_image (f, img, ximg, 0);
/* Final cleanup. image_wand should be the only resource left. */
DestroyMagickWand (image_wand);
@ -8338,7 +8533,7 @@ svg_load_image (struct frame *f, /* Pointer to emacs frame structure. *
eassert (fn_gdk_pixbuf_get_bits_per_sample (pixbuf) == 8);
/* Try to create a x pixmap to hold the svg pixmap. */
if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg, &img->pixmap))
if (!image_create_x_image_and_pixmap (f, img, width, height, 0, &ximg, 0))
{
fn_g_object_unref (pixbuf);
return 0;
@ -8413,10 +8608,8 @@ svg_load_image (struct frame *f, /* Pointer to emacs frame structure. *
Casting avoids a GCC warning. */
IMAGE_BACKGROUND (img, f, (XImagePtr_or_DC)ximg);
/* Put the image into the pixmap, then free the X image and its
buffer. */
x_put_x_image (f, ximg, img->pixmap, width, height);
x_destroy_x_image (ximg);
/* Put ximg into the image. */
image_put_x_image (f, img, ximg, 0);
return 1;
@ -8895,6 +9088,8 @@ non-numeric, there is no explicit limit on the size of images. */);
DEFSYM (Qheuristic, "heuristic");
DEFSYM (Qpostscript, "postscript");
DEFSYM (QCmax_width, ":max-width");
DEFSYM (QCmax_height, ":max-height");
#ifdef HAVE_GHOSTSCRIPT
ADD_IMAGE_TYPE (Qpostscript);
DEFSYM (QCloader, ":loader");

75
src/process.c
View file

@ -1590,7 +1590,6 @@ create_process (Lisp_Object process, char **new_argv, Lisp_Object current_dir)
#ifndef WINDOWSNT
int wait_child_setup[2];
#endif
sigset_t blocked;
int forkin, forkout;
bool pty_flag = 0;
Lisp_Object lisp_pty_name = Qnil;
@ -1685,12 +1684,7 @@ create_process (Lisp_Object process, char **new_argv, Lisp_Object current_dir)
encoded_current_dir = ENCODE_FILE (current_dir);
block_input ();
/* Block SIGCHLD until we have a chance to store the new fork's
pid in its process structure. */
sigemptyset (&blocked);
sigaddset (&blocked, SIGCHLD);
pthread_sigmask (SIG_BLOCK, &blocked, 0);
block_child_signal ();
#ifndef WINDOWSNT
/* vfork, and prevent local vars from being clobbered by the vfork. */
@ -1822,8 +1816,8 @@ create_process (Lisp_Object process, char **new_argv, Lisp_Object current_dir)
/* Emacs ignores SIGPIPE, but the child should not. */
signal (SIGPIPE, SIG_DFL);
/* Stop blocking signals in the child. */
pthread_sigmask (SIG_SETMASK, &empty_mask, 0);
/* Stop blocking SIGCHLD in the child. */
unblock_child_signal ();
if (pty_flag)
child_setup_tty (xforkout);
@ -1843,8 +1837,8 @@ create_process (Lisp_Object process, char **new_argv, Lisp_Object current_dir)
if (pid >= 0)
XPROCESS (process)->alive = 1;
/* Stop blocking signals in the parent. */
pthread_sigmask (SIG_SETMASK, &empty_mask, 0);
/* Stop blocking in the parent. */
unblock_child_signal ();
unblock_input ();
if (pid < 0)
@ -6125,9 +6119,10 @@ process has been transmitted to the serial port. */)
/* LIB_CHILD_HANDLER is a SIGCHLD handler that Emacs calls while doing
its own SIGCHLD handling. On POSIXish systems, glib needs this to
keep track of its own children. The default handler does nothing. */
keep track of its own children. GNUstep is similar. */
static void dummy_handler (int sig) {}
static signal_handler_t volatile lib_child_handler = dummy_handler;
static signal_handler_t volatile lib_child_handler;
/* Handle a SIGCHLD signal by looking for known child processes of
Emacs whose status have changed. For each one found, record its
@ -7060,35 +7055,29 @@ integer or floating point values.
return system_process_attributes (pid);
}
/* Arrange to catch SIGCHLD if needed. */
/* Arrange to catch SIGCHLD if this hasn't already been arranged.
Invoke this after init_process_emacs, and after glib and/or GNUstep
futz with the SIGCHLD handler, but before Emacs forks any children.
This function's caller should block SIGCHLD. */
#ifndef NS_IMPL_GNUSTEP
static
#endif
void
catch_child_signal (void)
{
struct sigaction action, old_action;
#if !defined CANNOT_DUMP
if (noninteractive && !initialized)
return;
#endif
#if defined HAVE_GLIB && !defined WINDOWSNT
/* Tickle glib's child-handling code. Ask glib to wait for Emacs itself;
this should always fail, but is enough to initialize glib's
private SIGCHLD handler, allowing the code below to copy it into
LIB_CHILD_HANDLER.
Do this early in Emacs initialization, before glib creates
threads, to avoid race condition bugs in Cygwin glib. */
g_source_unref (g_child_watch_source_new (getpid ()));
#endif
emacs_sigaction_init (&action, deliver_child_signal);
block_child_signal ();
sigaction (SIGCHLD, &action, &old_action);
eassert (! (old_action.sa_flags & SA_SIGINFO));
if (old_action.sa_handler != SIG_DFL && old_action.sa_handler != SIG_IGN
&& old_action.sa_handler != deliver_child_signal)
lib_child_handler = old_action.sa_handler;
if (old_action.sa_handler != deliver_child_signal)
lib_child_handler
= (old_action.sa_handler == SIG_DFL || old_action.sa_handler == SIG_IGN
? dummy_handler
: old_action.sa_handler);
unblock_child_signal ();
}
@ -7102,6 +7091,24 @@ init_process_emacs (void)
inhibit_sentinels = 0;
#ifndef CANNOT_DUMP
if (! noninteractive || initialized)
#endif
{
#if defined HAVE_GLIB && !defined WINDOWSNT && !defined CYGWIN
/* Tickle glib's child-handling code. Ask glib to wait for Emacs itself;
this should always fail, but is enough to initialize glib's
private SIGCHLD handler, allowing the code below to copy it into
LIB_CHILD_HANDLER.
For some reason tickling causes Cygwin bootstrap to fail, so it's
skipped under Cygwin. FIXME: Skipping the tickling likely causes
bugs in subprocess handling under Cygwin (Bug#14569). */
g_source_unref (g_child_watch_source_new (getpid ()));
#endif
catch_child_signal ();
}
FD_ZERO (&input_wait_mask);
FD_ZERO (&non_keyboard_wait_mask);
FD_ZERO (&non_process_wait_mask);

4
src/process.h
View file

@ -200,6 +200,8 @@ extern Lisp_Object QCflowcontrol, Qhw, Qsw, QCsummary;
/* Defined in callproc.c. */
extern void block_child_signal (void);
extern void unblock_child_signal (void);
extern void record_kill_process (struct Lisp_Process *);
/* Defined in process.c. */
@ -217,6 +219,8 @@ extern void add_read_fd (int fd, fd_callback func, void *data);
extern void delete_read_fd (int fd);
extern void add_write_fd (int fd, fd_callback func, void *data);
extern void delete_write_fd (int fd);
#ifdef NS_IMPL_GNUSTEP
extern void catch_child_signal (void);
#endif
INLINE_HEADER_END

2
src/sysdep.c
View file

@ -1901,8 +1901,6 @@ init_signals (bool dumping)
sigaction (SIGFPE, &action, 0);
}
catch_child_signal ();
#ifdef SIGUSR1
add_user_signal (SIGUSR1, "sigusr1");
#endif

40
test/ChangeLog
View file

@ -8,6 +8,46 @@
(decoder-tests-prefer-utf-8-write): New function.
(ert-test-decoder-prefer-utf-8): New test.
2013-06-27 Dmitry Gutov <dgutov@yandex.ru>
* automated/package-x-test.el: Change the commentary.
(package-x-test--single-archive-entry-1-3)
(package-x-test--single-archive-entry-1-4): Fix the tests, by
using the appropriate data structure.
2013-06-27 Daniel Hackney <dan@haxney.org>
* automated/Makefile.in (setwins): Include the 'data' subdirectory.
* automated/package-x-test.el: New file.
* automated/package-test.el: New file.
* automated/data/package: New directory, with test examples.
2013-06-27 Glenn Morris <rgm@gnu.org>
* automated/python-tests.el (python-tests-with-temp-file):
Clean up after ourself.
* automated/undo-tests.el (undo-test3): Remove test that seems to
do nothing that the previous one doesn't, except leave a tempfile.
2013-06-26 Glenn Morris <rgm@gnu.org>
* automated/info-xref.el: New file.
2013-06-25 Glenn Morris <rgm@gnu.org>
* automated/occur-tests.el (occur-test-create): New function.
Use it to create separate tests for each element, so we run them
all rather than stopping at the first error.
2013-06-24 Glenn Morris <rgm@fencepost.gnu.org>
* automated/occur-tests.el (occur-tests):
Update for 2013-05-29 change to occur header line.
2013-06-21 Eduard Wiebe <usenet@pusto.de>
Test suite for flymake.

2
test/automated/Makefile.in
View file

@ -50,7 +50,7 @@ emacs = EMACSLOADPATH=$(lispsrc):$(test) LC_ALL=C $(EMACS) $(EMACSOPT)
# Common command to find subdirectories
setwins=subdirs=`find . -type d -print`; \
for file in $$subdirs; do \
case $$file in */.* | */.*/* | */=* ) ;; \
case $$file in */.* | */.*/* | */=* | ./data* ) ;; \
*) wins="$$wins $$file" ;; \
esac; \
done

10
test/automated/data/package/archive-contents Normal file
View file

@ -0,0 +1,10 @@
(1
(simple-single .
[(1 3)
nil "A single-file package with no dependencies" single])
(simple-depend .
[(1 0)
((simple-single (1 3))) "A single-file package with a dependency." single])
(multi-file .
[(0 2 3)
nil "Example of a multi-file tar package" tar]))

BIN
test/automated/data/package/multi-file-0.2.3.tar Normal file
View file

Binary file not shown.

1
test/automated/data/package/multi-file-readme.txt Normal file
View file

@ -0,0 +1 @@
This is a bare-bones readme file for the multi-file package.

13
test/automated/data/package/newer-versions/archive-contents Normal file
View file

@ -0,0 +1,13 @@
(1
(simple-single .
[(1 4)
nil "A single-file package with no dependencies" single])
(simple-depend .
[(1 0)
((simple-single (1 3))) "A single-file package with a dependency." single])
(new-pkg .
[(1 0)
nil "A package only seen after "updating" archive-contents" single])
(multi-file .
[(0 2 3)
nil "Example of a multi-file tar package" tar]))

18
test/automated/data/package/newer-versions/new-pkg-1.0.el Normal file
View file

@ -0,0 +1,18 @@
;;; new-pkg.el --- A package only seen after "updating" archive-contents
;; Author: J. R. Hacker <jrh@example.com>
;; Version: 1.0
;;; Commentary:
;; This will only show up after updating "archive-contents".
;;; Code:
(defun new-pkg-frob ()
"Ignore me."
(ignore))
(provide 'new-pkg)
;;; new-pkg.el ends here

36
test/automated/data/package/newer-versions/simple-single-1.4.el Normal file
View file

@ -0,0 +1,36 @@
;;; simple-single.el --- A single-file package with no dependencies
;; Author: J. R. Hacker <jrh@example.com>
;; Version: 1.4
;; Keywords: frobnicate
;;; Commentary:
;; This package provides a minor mode to frobnicate and/or bifurcate
;; any flanges you desire. To activate it, type "C-M-r M-3 butterfly"
;; and all your dreams will come true.
;;
;; This is a new, updated version.
;;; Code:
(defgroup simple-single nil "Simply a file"
:group 'lisp)
(defcustom simple-single-super-sunday nil
"How great is this?
Default changed to `nil'."
:type 'boolean
:group 'simple-single
:package-version "1.4")
(defvar simple-single-sudo-sandwich nil
"Make a sandwich?")
;;;###autoload
(define-minor-mode simple-single-mode
"It does good things to stuff")
(provide 'simple-single)
;;; simple-single.el ends here

17
test/automated/data/package/simple-depend-1.0.el Normal file
View file

@ -0,0 +1,17 @@
;;; simple-depend.el --- A single-file package with a dependency.
;; Author: J. R. Hacker <jrh@example.com>
;; Version: 1.0
;; Keywords: frobnicate
;; Package-Requires: ((simple-single "1.3"))
;;; Commentary:
;; Depends on another package.
;;; Code:
(defvar simple-depend "Value"
"Some trivial code")
;;; simple-depend.el ends here

32
test/automated/data/package/simple-single-1.3.el Normal file
View file

@ -0,0 +1,32 @@
;;; simple-single.el --- A single-file package with no dependencies
;; Author: J. R. Hacker <jrh@example.com>
;; Version: 1.3
;; Keywords: frobnicate
;;; Commentary:
;; This package provides a minor mode to frobnicate and/or bifurcate
;; any flanges you desire. To activate it, type "C-M-r M-3 butterfly"
;; and all your dreams will come true.
;;; Code:
(defgroup simple-single nil "Simply a file"
:group 'lisp)
(defcustom simple-single-super-sunday t
"How great is this?"
:type 'boolean
:group 'simple-single)
(defvar simple-single-sudo-sandwich nil
"Make a sandwich?")
;;;###autoload
(define-minor-mode simple-single-mode
"It does good things to stuff")
(provide 'simple-single)
;;; simple-single.el ends here

3
test/automated/data/package/simple-single-readme.txt Normal file
View file

@ -0,0 +1,3 @@
This package provides a minor mode to frobnicate and/or bifurcate
any flanges you desire. To activate it, type "C-M-r M-3 butterfly"
and all your dreams will come true.

148
test/automated/info-xref.el Normal file
View file

@ -0,0 +1,148 @@
;;; info-xref.el --- tests for info-xref.el
;; Copyright (C) 2013 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(require 'ert)
(require 'info-xref)
(defun info-xref-test-internal (body result)
"Body of a basic info-xref ert test.
BODY is a string from an info buffer.
RESULT is a list (NBAD NGOOD NUNAVAIL)."
(get-buffer-create info-xref-output-buffer)
(setq info-xref-xfile-alist nil)
(require 'info)
(let ((Info-directory-list '("."))
Info-additional-directory-list)
(info-xref-with-output
(with-temp-buffer
(insert body)
(info-xref-check-buffer))))
(should (equal result (list info-xref-bad info-xref-good info-xref-unavail)))
;; If there was an error, we can leave this around.
(kill-buffer info-xref-output-buffer))
(ert-deftest info-xref-test-node-crossref ()
"Test parsing of @xref{node,crossref,,manual} with Texinfo 4/5."
(info-xref-test-internal "
*Note crossref: (manual-foo)node. Texinfo 4/5 format with crossref.
" '(0 0 1)))
(ert-deftest info-xref-test-node-4 ()
"Test parsing of @xref{node,,,manual} with Texinfo 4."
(info-xref-test-internal "
*Note node: (manual-foo)node. Texinfo 4 format with no crossref.
" '(0 0 1)))
(ert-deftest info-xref-test-node-5 ()
"Test parsing of @xref{node,,,manual} with Texinfo 5."
(info-xref-test-internal "
*Note (manual-foo)node::. Texinfo 5 format with no crossref.
" '(0 0 1)))
;; TODO Easier to have static data files in the repo?
(defun info-xref-test-write-file (file body)
"Write BODY to texi FILE."
(with-temp-buffer
(insert "\
\input texinfo
@setfilename "
(format "%s.info\n" (file-name-sans-extension file))
"\
@settitle test
@ifnottex
@node Top
@top test
@end ifnottex
@menu
* Chapter One::
@end menu
@node Chapter One
@chapter Chapter One
text.
"
body
"\
@bye
"
)
(write-region nil nil file nil 'silent))
(should (equal 0 (call-process "makeinfo" file))))
(ert-deftest info-xref-test-makeinfo ()
"Test that info-xref can parse basic makeinfo output."
:expected-result (if (executable-find "makeinfo") :passed :failed)
(should (executable-find "makeinfo"))
(let ((tempfile (make-temp-file "info-xref-test" nil ".texi"))
(tempfile2 (make-temp-file "info-xref-test2" nil ".texi"))
(errflag t))
(unwind-protect
(progn
;; tempfile contains xrefs to various things, including tempfile2.
(info-xref-test-write-file
tempfile
(concat "\
@xref{nodename,,,missing,Missing Manual}.
@xref{nodename,crossref,title,missing,Missing Manual}.
@xref{Chapter One}.
@xref{Chapter One,Something}.
"
(format "@xref{Chapter One,,,%s,Present Manual}.\n"
(file-name-sans-extension (file-name-nondirectory
tempfile2)))))
;; Something for tempfile to xref to.
(info-xref-test-write-file tempfile2 "")
(require 'info)
(save-window-excursion
(let ((Info-directory-list
(list
(or (file-name-directory tempfile) ".")))
Info-additional-directory-list)
(info-xref-check (format "%s.info" (file-name-sans-extension
tempfile))))
(should (equal (list info-xref-bad info-xref-good
info-xref-unavail)
'(0 1 2)))
(setq errflag nil)
;; If there was an error, we can leave this around.
(kill-buffer info-xref-output-buffer)))
;; Useful diagnostic in case of problems.
(if errflag
(with-temp-buffer
(call-process "makeinfo" nil t nil "--version")
(message "%s" (buffer-string))))
(mapc 'delete-file (list tempfile tempfile2
(format "%s.info" (file-name-sans-extension
tempfile))
(format "%s.info" (file-name-sans-extension
tempfile2)))))))
;;; info-xref.el ends here

20
test/automated/occur-tests.el
View file

@ -35,7 +35,7 @@ xd
xex
fx
" "\
5 matches for \"x\" in buffer: *test-occur*
6 matches in 5 lines for \"x\" in buffer: *test-occur*
1:xa
3:cx
4:xd
@ -335,12 +335,18 @@ Each element has the format:
(and (buffer-name temp-buffer)
(kill-buffer temp-buffer)))))
(ert-deftest occur-tests ()
"Test the functionality of `occur'.
The test data is in the `occur-tests' constant."
(let ((occur-hook nil))
(dolist (test occur-tests)
(should (occur-test-case test)))))
(defun occur-test-create (n)
"Create a test for element N of the `occur-tests' constant."
(let ((testname (intern (format "occur-test-%.2d" n)))
(testdoc (format "Test element %d of `occur-tests'." n)))
(eval
`(ert-deftest ,testname ()
,testdoc
(let (occur-hook)
(should (occur-test-case (nth ,n occur-tests))))))))
(dotimes (i (length occur-tests))
(occur-test-create i))
(provide 'occur-tests)

398
test/automated/package-test.el Executable file
View file

@ -0,0 +1,398 @@
;;; package-test.el --- Tests for the Emacs package system
;; Copyright (C) 2013 Free Software Foundation, Inc.
;; Author: Daniel Hackney <dan@haxney.org>
;; Version: 1.0
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; You may want to run this from a separate Emacs instance from your
;; main one, because a bug in the code below could mess with your
;; installed packages.
;; Run this in a clean Emacs session using:
;;
;; $ emacs -Q --batch -L . -l package-test.el -l ert -f ert-run-tests-batch-and-exit
;;; Code:
(require 'package)
(require 'ert)
(require 'cl-lib)
(defvar package-test-user-dir nil
"Directory to use for installing packages during testing.")
(defvar package-test-file-dir (file-name-directory (or load-file-name
buffer-file-name))
"Directory of the actual \"package-test.el\" file.")
(defvar simple-single-desc
(package-desc-create :name 'simple-single
:version '(1 3)
:summary "A single-file package with no dependencies"
:kind 'single)
"Expected `package-desc' parsed from simple-single-1.3.el.")
(defvar simple-single-desc-1-4
(package-desc-create :name 'simple-single
:version '(1 4)
:summary "A single-file package with no dependencies"
:kind 'single)
"Expected `package-desc' parsed from simple-single-1.4.el.")
(defvar simple-depend-desc
(package-desc-create :name 'simple-depend
:version '(1 0)
:summary "A single-file package with a dependency."
:kind 'single
:reqs '((simple-single (1 3))))
"Expected `package-desc' parsed from simple-depend-1.0.el.")
(defvar multi-file-desc
(package-desc-create :name 'multi-file
:version '(0 2 3)
:summary "Example of a multi-file tar package"
:kind 'tar)
"Expected `package-desc' from \"multi-file-0.2.3.tar\".")
(defvar new-pkg-desc
(package-desc-create :name 'new-pkg
:version '(1 0)
:kind 'single)
"Expected `package-desc' parsed from new-pkg-1.0.el.")
(defvar package-test-data-dir (expand-file-name "data/package" package-test-file-dir)
"Base directory of package test files.")
(defvar package-test-fake-contents-file
(expand-file-name "archive-contents" package-test-data-dir)
"Path to a static copy of \"archive-contents\".")
(defvar package-test-built-file-suffixes '(".tar" "/dir" "/*.info")
"Remove these files when cleaning up a built package.")
(cl-defmacro with-package-test ((&optional &key file
basedir
install
update-news
upload-base)
&rest body)
"Set up temporary locations and variables for testing."
(declare (indent 1))
`(let* ((package-test-user-dir (make-temp-file "pkg-test-user-dir-" t))
(package-user-dir package-test-user-dir)
(package-archives `(("gnu" . ,package-test-data-dir)))
(old-yes-no-defn (symbol-function 'yes-or-no-p))
(old-pwd default-directory)
package--initialized
package-alist
,@(if update-news
'(package-update-news-on-upload t)
(list (cl-gensym)))
,@(if upload-base
'((package-test-archive-upload-base (make-temp-file "pkg-archive-base-" t))
(package-archive-upload-base package-test-archive-upload-base))
(list (cl-gensym)))) ;; Dummy value so `let' doesn't try to bind `nil'
(unwind-protect
(progn
,(if basedir `(cd ,basedir))
(setf (symbol-function 'yes-or-no-p) #'(lambda (&rest r) t))
(unless (file-directory-p package-user-dir)
(mkdir package-user-dir))
,@(when install
`((package-initialize)
(package-refresh-contents)
(mapc 'package-install ,install)))
(with-temp-buffer
,(if file
`(insert-file-contents ,file))
,@body))
(when (file-directory-p package-test-user-dir)
(delete-directory package-test-user-dir t))
(when (and (boundp 'package-test-archive-upload-base)
(file-directory-p package-test-archive-upload-base))
(delete-directory package-test-archive-upload-base t))
(setf (symbol-function 'yes-or-no-p) old-yes-no-defn)
(cd old-pwd))))
(defmacro with-fake-help-buffer (&rest body)
"Execute BODY in a temp buffer which is treated as the \"*Help*\" buffer."
`(with-temp-buffer
(help-mode)
;; Trick `help-buffer' into using the temp buffer.
(let ((help-xref-following t))
,@body)))
(defun package-test-install-texinfo (file)
"Install from texinfo FILE.
FILE should be a .texinfo file relative to the current
`default-directory'"
(require 'info)
(let* ((full-file (expand-file-name file))
(info-file (replace-regexp-in-string "\\.texi\\'" ".info" full-file))
(old-info-defn (symbol-function 'Info-revert-find-node)))
(require 'info)
(setf (symbol-function 'Info-revert-find-node) #'ignore)
(with-current-buffer (find-file-literally full-file)
(unwind-protect
(progn
(require 'makeinfo)
(makeinfo-buffer)
;; Give `makeinfo-buffer' a chance to finish
(while compilation-in-progress
(sit-for 0.1))
(call-process "ginstall-info" nil nil nil
(format "--info-dir=%s" default-directory)
(format "%s" info-file)))
(kill-buffer)
(setf (symbol-function 'Info-revert-find-node) old-info-defn)))))
(defun package-test-strip-version (dir)
(replace-regexp-in-string "-pkg\\.el\\'" "" (package--description-file dir)))
(defun package-test-suffix-matches (base suffix-list)
"Return file names matching BASE concatenated with each item in SUFFIX-LIST"
(cl-mapcan
'(lambda (item) (file-expand-wildcards (concat base item)))
suffix-list))
(defun package-test-cleanup-built-files (dir)
"Remove files which were the result of creating a tar archive.
DIR is the base name of the package directory, without the trailing slash"
(let* ((pkg-dirname (file-name-nondirectory dir)))
(dolist (file (package-test-suffix-matches dir package-test-built-file-suffixes))
(delete-file file))))
(defun package-test-search-tar-file (filename)
"Search the current buffer's `tar-parse-info' variable for FILENAME.
Must called from within a `tar-mode' buffer."
(cl-dolist (header tar-parse-info)
(let ((tar-name (tar-header-name header)))
(when (string= tar-name filename)
(cl-return t)))))
(defun package-test-desc-version-string (desc)
"Return the package version as a string."
(package-version-join (package-desc-version desc)))
(ert-deftest package-test-desc-from-buffer ()
"Parse an elisp buffer to get a `package-desc' object."
(with-package-test (:basedir "data/package" :file "simple-single-1.3.el")
(should (equal (package-buffer-info) simple-single-desc)))
(with-package-test (:basedir "data/package" :file "simple-depend-1.0.el")
(should (equal (package-buffer-info) simple-depend-desc)))
(with-package-test (:basedir "data/package"
:file "multi-file-0.2.3.tar")
(tar-mode)
(should (equal (package-tar-file-info) multi-file-desc))))
(ert-deftest package-test-install-single ()
"Install a single file without using an archive."
(with-package-test (:basedir "data/package" :file "simple-single-1.3.el")
(should (package-install-from-buffer))
(package-initialize)
(should (package-installed-p 'simple-single))
(let* ((simple-pkg-dir (file-name-as-directory
(expand-file-name
"simple-single-1.3"
package-test-user-dir)))
(autoloads-file (expand-file-name "simple-single-autoloads.el"
simple-pkg-dir)))
(should (file-directory-p simple-pkg-dir))
(with-temp-buffer
(insert-file-contents (expand-file-name "simple-single-pkg.el"
simple-pkg-dir))
(should (string= (buffer-string)
(concat "(define-package \"simple-single\" \"1.3\" "
"\"A single-file package "
"with no dependencies\" 'nil)\n"))))
(should (file-exists-p autoloads-file))
(should-not (get-file-buffer autoloads-file)))))
(ert-deftest package-test-install-dependency ()
"Install a package which includes a dependency."
(with-package-test ()
(package-initialize)
(package-refresh-contents)
(package-install 'simple-depend)
(should (package-installed-p 'simple-single))
(should (package-installed-p 'simple-depend))))
(ert-deftest package-test-refresh-contents ()
"Parse an \"archive-contents\" file."
(with-package-test ()
(package-initialize)
(package-refresh-contents)
(should (eq 3 (length package-archive-contents)))))
(ert-deftest package-test-install-single-from-archive ()
"Install a single package from a package archive."
(with-package-test ()
(package-initialize)
(package-refresh-contents)
(package-install 'simple-single)))
(ert-deftest package-test-install-multifile ()
"Check properties of the installed multi-file package."
(with-package-test (:basedir "data/package" :install '(multi-file))
(let ((autoload-file
(expand-file-name "multi-file-autoloads.el"
(expand-file-name
"multi-file-0.2.3"
package-test-user-dir)))
(installed-files '("dir" "multi-file.info" "multi-file-sub.elc"
"multi-file-autoloads.el" "multi-file.elc"))
(autoload-forms '("^(defvar multi-file-custom-var"
"^(custom-autoload 'multi-file-custom-var"
"^(autoload 'multi-file-mode"))
(pkg-dir (file-name-as-directory
(expand-file-name
"multi-file-0.2.3"
package-test-user-dir))))
(package-refresh-contents)
(should (package-installed-p 'multi-file))
(with-temp-buffer
(insert-file-contents-literally autoload-file)
(dolist (fn installed-files)
(should (file-exists-p (expand-file-name fn pkg-dir))))
(dolist (re autoload-forms)
(goto-char (point-min))
(should (re-search-forward re nil t)))))))
(ert-deftest package-test-update-listing ()
"Ensure installed package status is updated."
(with-package-test ()
(let ((buf (package-list-packages)))
(search-forward-regexp "^ +simple-single")
(package-menu-mark-install)
(package-menu-execute)
(should (package-installed-p 'simple-single))
(switch-to-buffer "*Packages*")
(goto-char (point-min))
(should (re-search-forward "^\\s-+simple-single\\s-+1.3\\s-+installed" nil t))
(goto-char (point-min))
(should-not (re-search-forward "^\\s-+simple-single\\s-+1.3\\s-+\\(available\\|new\\)" nil t))
(kill-buffer buf))))
(ert-deftest package-test-update-archives ()
"Test updating package archives."
(with-package-test ()
(let ((buf (package-list-packages)))
(package-menu-refresh)
(search-forward-regexp "^ +simple-single")
(package-menu-mark-install)
(package-menu-execute)
(should (package-installed-p 'simple-single))
(let ((package-test-data-dir
(expand-file-name "data/package/newer-versions" package-test-file-dir)))
(setq package-archives `(("gnu" . ,package-test-data-dir)))
(package-menu-refresh)
;; New version should be available and old version should be installed
(goto-char (point-min))
(should (re-search-forward "^\\s-+simple-single\\s-+1.4\\s-+new" nil t))
(should (re-search-forward "^\\s-+simple-single\\s-+1.3\\s-+installed" nil t))
(goto-char (point-min))
(should (re-search-forward "^\\s-+new-pkg\\s-+1.0\\s-+\\(available\\|new\\)" nil t))
(package-menu-mark-upgrades)
(package-menu-execute)
(package-menu-refresh)
(should (package-installed-p 'simple-single '(1 4)))))))
(ert-deftest package-test-describe-package ()
"Test displaying help for a package."
(require 'finder-inf)
;; Built-in
(with-fake-help-buffer
(describe-package '5x5)
(goto-char (point-min))
(should (search-forward "5x5 is a built-in package." nil t))
(should (search-forward "Status: Built-in." nil t))
(should (search-forward "Summary: simple little puzzle game" nil t))
(should (search-forward "The aim of 5x5" nil t)))
;; Installed
(with-package-test ()
(package-initialize)
(package-refresh-contents)
(package-install 'simple-single)
(with-fake-help-buffer
(describe-package 'simple-single)
(goto-char (point-min))
(should (search-forward "simple-single is an installed package." nil t))
(should (search-forward
(format "Status: Installed in `%s/'."
(expand-file-name "simple-single-1.3" package-user-dir))
nil t))
(should (search-forward "Version: 1.3" nil t))
(should (search-forward "Summary: A single-file package with no dependencies"
nil t))
;; No description, though. Because at this point we don't know
;; what archive the package originated from, and we don't have
;; its readme file saved.
)))
(ert-deftest package-test-describe-not-installed-package ()
"Test displaying of the readme for not-installed package."
(with-package-test ()
(package-initialize)
(package-refresh-contents)
(with-fake-help-buffer
(describe-package 'simple-single)
(goto-char (point-min))
(should (search-forward "This package provides a minor mode to frobnicate"
nil t)))))
(ert-deftest package-test-describe-non-installed-package ()
"Test displaying of the readme for non-installed package."
(with-package-test ()
(package-initialize)
(package-refresh-contents)
(with-fake-help-buffer
(describe-package 'simple-single)
(goto-char (point-min))
(should (search-forward "This package provides a minor mode to frobnicate"
nil t)))))
(ert-deftest package-test-describe-non-installed-multi-file-package ()
"Test displaying of the readme for non-installed multi-file package."
(with-package-test ()
(package-initialize)
(package-refresh-contents)
(with-fake-help-buffer
(describe-package 'multi-file)
(goto-char (point-min))
(should (search-forward "This is a bare-bones readme file for the multi-file"
nil t)))))
(provide 'package-test)
;;; package-test.el ends here

107
test/automated/package-x-test.el Executable file
View file

@ -0,0 +1,107 @@
;;; package-test.el --- Tests for the Emacs package system
;; Copyright (C) 2013 Free Software Foundation, Inc.
;; Author: Daniel Hackney <dan@haxney.org>
;; Version: 1.0
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; You may want to run this from a separate Emacs instance from your
;; main one, because a bug in the code below could mess with your
;; installed packages.
;; Run this in a clean Emacs session using:
;;
;; $ emacs -Q --batch -L . -l package-x-test.el -f ert-run-tests-batch-and-exit
;;; Code:
(require 'package-x)
(require 'ert)
(require 'cl-lib)
;; package-test is not normally in `load-path', so temporarily set
;; `load-path' to contain the current directory.
(let ((load-path (append (list (file-name-directory (or load-file-name
buffer-file-name)))
load-path)))
(require 'package-test))
(defvar package-x-test--single-archive-entry-1-3
(cons 'simple-single
(package-make-ac-desc '(1 3) nil
"A single-file package with no dependencies"
'single))
"Expected contents of the archive entry from the \"simple-single\" package.")
(defvar package-x-test--single-archive-entry-1-4
(cons 'simple-single
(package-make-ac-desc '(1 4) nil
"A single-file package with no dependencies"
'single))
"Expected contents of the archive entry from the updated \"simple-single\" package.")
(ert-deftest package-x-test-upload-buffer ()
"Test creating an \"archive-contents\" file"
(with-package-test (:basedir "data/package"
:file "simple-single-1.3.el"
:upload-base t)
(package-upload-buffer)
(should (file-exists-p (expand-file-name "archive-contents"
package-archive-upload-base)))
(should (file-exists-p (expand-file-name "simple-single-1.3.el"
package-archive-upload-base)))
(should (file-exists-p (expand-file-name "simple-single-readme.txt"
package-archive-upload-base)))
(let (archive-contents)
(with-temp-buffer
(insert-file-contents
(expand-file-name "archive-contents"
package-archive-upload-base))
(setq archive-contents
(package-read-from-string
(buffer-substring (point-min) (point-max)))))
(should (equal archive-contents
(list 1 package-x-test--single-archive-entry-1-3))))))
(ert-deftest package-x-test-upload-new-version ()
"Test uploading a new version of a package"
(with-package-test (:basedir "data/package"
:file "simple-single-1.3.el"
:upload-base t)
(package-upload-buffer)
(with-temp-buffer
(insert-file-contents "newer-versions/simple-single-1.4.el")
(package-upload-buffer))
(let (archive-contents)
(with-temp-buffer
(insert-file-contents
(expand-file-name "archive-contents"
package-archive-upload-base))
(setq archive-contents
(package-read-from-string
(buffer-substring (point-min) (point-max)))))
(should (equal archive-contents
(list 1 package-x-test--single-archive-entry-1-4))))))
(provide 'package-x-test)
;;; package-x-test.el ends here

6
test/automated/python-tests.el
View file

@ -39,7 +39,8 @@ always located at the beginning of buffer."
BODY is code to be executed within the temp buffer. Point is
always located at the beginning of buffer."
(declare (indent 1) (debug t))
`(let* ((temp-file (concat (make-temp-file "python-tests") ".py"))
;; temp-file never actually used for anything?
`(let* ((temp-file (make-temp-file "python-tests" nil ".py"))
(buffer (find-file-noselect temp-file)))
(unwind-protect
(with-current-buffer buffer
@ -47,7 +48,8 @@ always located at the beginning of buffer."
(insert ,contents)
(goto-char (point-min))
,@body)
(and buffer (kill-buffer buffer)))))
(and buffer (kill-buffer buffer))
(delete-file temp-file))))
(defun python-tests-look-at (string &optional num restore-point)
"Move point at beginning of STRING in the current buffer.

22
test/automated/undo-tests.el
View file

@ -1,6 +1,6 @@
;;; undo-tests.el --- Tests of primitive-undo
;; Copyright (C) 2012 Aaron S. Hawley
;; Copyright (C) 2012-2013 Free Software Foundation, Inc.
;; Author: Aaron S. Hawley <aaron.s.hawley@gmail.com>
@ -140,26 +140,6 @@
(undo)
(buffer-string))))))
(ert-deftest undo-test3 ()
"Test modtime with \\[undo] command."
(let ((tmpfile (make-temp-file "undo-test3")))
(with-temp-file tmpfile
(let ((buffer-file-name tmpfile))
(buffer-enable-undo)
(set (make-local-variable 'make-backup-files) nil)
(undo-boundary)
(insert ?\s)
(undo-boundary)
(basic-save-buffer)
(insert ?\t)
(undo)
(should
(string-equal (buffer-string)
(progn
(undo)
(buffer-string)))))
(delete-file tmpfile))))
(ert-deftest undo-test4 ()
"Test \\[undo] of \\[flush-lines]."
(with-temp-buffer