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

merge from trunk

Browse source
This commit is contained in:
Tom Tromey 2013-08-25 14:25:59 -06:00
commit 793ea5055a
54 changed files with 2945 additions and 1062 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

26
ChangeLog
View file

@ -1,3 +1,29 @@
2013-08-22 Paul Eggert <eggert@cs.ucla.edu>
* configure.ac (EMACS_CONFIG_OPTIONS): Quote systematically (Bug#13274).
This improves on the patch already installed, by quoting options
that contain spaces and suchlike systematically, so that
EMACS_CONFIG_OPTIONS is no longer ambiguous when options contain
these characters.
2013-08-21 Paul Eggert <eggert@cs.ucla.edu>
Port close-on-exec pty creation to FreeBSD 9.1-RELEASE (Bug#15129).
* configure.ac (PTY_OPEN): If posix_openpt with O_CLOEXEC fails
and reports EINVAL, try it again without O_CLOEXEC. This should
port PTY_OPEN to FreeBSD 9, which stupidly rejects O_CLOEXEC.
What were they thinking?
2013-08-20 Paul Eggert <eggert@cs.ucla.edu>
* Makefile.in (distclean, bootstrap-clean, maintainer-clean):
Fix shell-operator precedence problem in previous change.
2013-08-20 Glenn Morris <rgm@gnu.org>
* Makefile.in (distclean, bootstrap-clean, maintainer-clean):
Clean test/automated if present.
2013-08-19 Paul Eggert <eggert@cs.ucla.edu>
Merge from gnulib, incorporating:

9
Makefile.in
View file

@ -859,6 +859,9 @@ distclean: FRC
(cd leim; $(MAKE) $(MFLAGS) distclean)
(cd lisp; $(MAKE) $(MFLAGS) distclean)
(cd nextstep && $(MAKE) $(MFLAGS) distclean)
[ ! -d test/automated ] || { \
cd test/automated && $(MAKE) $(MFLAGS) distclean; \
}
${top_distclean}
### `bootstrap-clean'
@ -878,6 +881,9 @@ bootstrap-clean: FRC
(cd leim; $(MAKE) $(MFLAGS) maintainer-clean)
(cd lisp; $(MAKE) $(MFLAGS) bootstrap-clean)
(cd nextstep && $(MAKE) $(MFLAGS) maintainer-clean)
[ ! -d test/automated ] || { \
cd test/automated && $(MAKE) $(MFLAGS) bootstrap-clean; \
}
[ ! -f config.log ] || mv -f config.log config.log~
${top_bootclean}
@ -898,6 +904,9 @@ top_maintainer_clean=\
maintainer-clean: bootstrap-clean FRC
(cd src; $(MAKE) $(MFLAGS) maintainer-clean)
(cd lisp; $(MAKE) $(MFLAGS) maintainer-clean)
[ ! -d test/automated ] || { \
cd test/automated && $(MAKE) $(MFLAGS) maintainer-clean; \
}
${top_maintainer_clean}
### This doesn't actually appear in the coding standards, but Karl

44
autogen/configure vendored
View file

@ -3486,16 +3486,37 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu
emacs_config_options="$@"
## Add some environment variables, if they were passed via the environment
## rather than on the command-line.
for var in CFLAGS CPPFLAGS LDFLAGS; do
case "$emacs_config_options" in
*$var=*) continue ;;
esac
eval val="\$${var}"
test x"$val" = x && continue
emacs_config_options="${emacs_config_options}${emacs_config_options:+ }$var=\"$val\""
emacs_config_options=
optsep=
for opt in ${1+"$@"} CFLAGS CPPFLAGS LDFLAGS; do
case $opt in
-n | --no-create | --no-recursion)
continue ;;
CFLAGS | CPPFLAGS | LDFLAGS)
eval 'test "${'$opt'+set}" = set' || continue
case " $*" in
*" $opt="*) continue ;;
esac
eval opt=$opt=\$$opt ;;
esac
emacs_shell_specials=$IFS\''"#$&()*;<>?[\\`{|~'
case $opt in
*["$emacs_shell_specials"]*)
case $opt in
*\'*)
emacs_quote_apostrophes="s/'/'\\\\''/g"
opt=`$as_echo "$opt" | sed "$emacs_quote_apostrophes"` ;;
esac
opt="'$opt'"
case $opt in
*['"\\']*)
emacs_quote_for_c='s/["\\]/\\&/g; $!s/$/\\n\\/'
opt=`$as_echo "$opt" | sed "$emacs_quote_for_c"` ;;
esac ;;
esac
as_fn_append emacs_config_options "$optsep$opt"
optsep=' '
done
ac_config_headers="$ac_config_headers src/config.h:src/config.in"
@ -16573,7 +16594,7 @@ $as_echo "#define UNIX98_PTYS 1" >>confdefs.h
$as_echo "#define PTY_TTY_NAME_SPRINTF { char *ptyname = 0; sigset_t blocked; sigemptyset (&blocked); sigaddset (&blocked, SIGCHLD); pthread_sigmask (SIG_BLOCK, &blocked, 0); if (grantpt (fd) != -1 && unlockpt (fd) != -1) ptyname = ptsname(fd); pthread_sigmask (SIG_UNBLOCK, &blocked, 0); if (!ptyname) { emacs_close (fd); return -1; } snprintf (pty_name, PTY_NAME_SIZE, \"%s\", ptyname); }" >>confdefs.h
if test "x$ac_cv_func_posix_openpt" = xyes; then
$as_echo "#define PTY_OPEN fd = posix_openpt (O_RDWR | O_CLOEXEC | O_NOCTTY)" >>confdefs.h
$as_echo "#define PTY_OPEN do { fd = posix_openpt (O_RDWR | O_CLOEXEC | O_NOCTTY); if (fd < 0 && errno == EINVAL) fd = posix_openpt (O_RDWR | O_NOCTTY); } while (0)" >>confdefs.h
$as_echo "#define PTY_NAME_SPRINTF /**/" >>confdefs.h
@ -17173,7 +17194,6 @@ cat >>confdefs.h <<_ACEOF
#define EMACS_CONFIGURATION "${canonical}"
_ACEOF
emacs_config_options=`echo "$emacs_config_options " | sed -e 's/--no-create //' -e 's/--no-recursion //' -e 's/ *$//' -e "s/\"/'/g" -e 's/\\\\/\\\\\\\\/g'`
cat >>confdefs.h <<_ACEOF
#define EMACS_CONFIG_OPTIONS "${emacs_config_options}"

49
configure.ac
View file

@ -24,18 +24,43 @@ dnl along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
AC_PREREQ(2.65)
AC_INIT(emacs, 24.3.50)
dnl Set emacs_config_options to the options of 'configure', quoted for the shell,
dnl and then quoted again for a C string. Separate options with spaces.
dnl Add some environment variables, if they were passed via the environment
dnl rather than on the command-line.
emacs_config_options=
optsep=
dnl This is the documented way to record the args passed to configure,
dnl rather than $ac_configure_args.
emacs_config_options="$@"
## Add some environment variables, if they were passed via the environment
## rather than on the command-line.
for var in CFLAGS CPPFLAGS LDFLAGS; do
case "$emacs_config_options" in
*$var=*) continue ;;
esac
eval val="\$${var}"
test x"$val" = x && continue
emacs_config_options="${emacs_config_options}${emacs_config_options:+ }$var=\"$val\""
for opt in ${1+"$@"} CFLAGS CPPFLAGS LDFLAGS; do
case $opt in
-n | --no-create | --no-recursion)
continue ;;
CFLAGS | CPPFLAGS | LDFLAGS)
eval 'test "${'$opt'+set}" = set' || continue
case " $*" in
*" $opt="*) continue ;;
esac
eval opt=$opt=\$$opt ;;
esac
emacs_shell_specials=$IFS\''"#$&()*;<>?@<:@\\`{|~'
case $opt in
*[["$emacs_shell_specials"]]*)
case $opt in
*\'*)
emacs_quote_apostrophes="s/'/'\\\\''/g"
opt=`AS_ECHO(["$opt"]) | sed "$emacs_quote_apostrophes"` ;;
esac
opt="'$opt'"
case $opt in
*[['"\\']]*)
emacs_quote_for_c='s/[["\\]]/\\&/g; $!s/$/\\n\\/'
opt=`AS_ECHO(["$opt"]) | sed "$emacs_quote_for_c"` ;;
esac ;;
esac
AS_VAR_APPEND([emacs_config_options], ["$optsep$opt"])
optsep=' '
done
AC_CONFIG_HEADER(src/config.h:src/config.in)
@ -3994,7 +4019,7 @@ case $opsys in
AC_DEFINE(PTY_TTY_NAME_SPRINTF, [{ char *ptyname = 0; sigset_t blocked; sigemptyset (&blocked); sigaddset (&blocked, SIGCHLD); pthread_sigmask (SIG_BLOCK, &blocked, 0); if (grantpt (fd) != -1 && unlockpt (fd) != -1) ptyname = ptsname(fd); pthread_sigmask (SIG_UNBLOCK, &blocked, 0); if (!ptyname) { emacs_close (fd); return -1; } snprintf (pty_name, PTY_NAME_SIZE, "%s", ptyname); }])
dnl if HAVE_POSIX_OPENPT
if test "x$ac_cv_func_posix_openpt" = xyes; then
AC_DEFINE(PTY_OPEN, [fd = posix_openpt (O_RDWR | O_CLOEXEC | O_NOCTTY)])
AC_DEFINE(PTY_OPEN, [do { fd = posix_openpt (O_RDWR | O_CLOEXEC | O_NOCTTY); if (fd < 0 && errno == EINVAL) fd = posix_openpt (O_RDWR | O_NOCTTY); } while (0)])
AC_DEFINE(PTY_NAME_SPRINTF, [])
dnl if HAVE_GETPT
elif test "x$ac_cv_func_getpt" = xyes; then
@ -4440,8 +4465,6 @@ fi
AC_DEFINE_UNQUOTED(EMACS_CONFIGURATION, "${canonical}",
[Define to the canonical Emacs configuration name.])
dnl Replace any embedded " characters (bug#13274).
emacs_config_options=`echo "$emacs_config_options " | sed -e 's/--no-create //' -e 's/--no-recursion //' -e 's/ *$//' -e "s/\"/'/g" -e 's/\\\\/\\\\\\\\/g'`
AC_DEFINE_UNQUOTED(EMACS_CONFIG_OPTIONS, "${emacs_config_options}",
[Define to the options passed to configure.])
AH_TEMPLATE(config_opsysfile, [Some platforms that do not use configure

5
doc/lispref/ChangeLog
View file

@ -1,3 +1,8 @@
2013-08-20 Eli Zaretskii <eliz@gnu.org>
* files.texi (Information about Files): Mention file names with
trailing blanks on MS-Windows. (Bug#15130)
2013-08-18 Xue Fuqiao <xfq.free@gmail.com>
* positions.texi (Positions): Improve indexing.

8
doc/lispref/files.texi
View file

@ -776,6 +776,14 @@ return information about actual files or directories, so their
arguments must all exist as actual files or directories unless
otherwise noted.
@cindex file names, trailing whitespace
@cindex trailing blanks in file names
Be careful with file names that end in blanks: some filesystems
(notably, MS-Windows) will ignore trailing whitespace in file names,
and return information about the file after stripping those blanks
from the name, not about the file whose name you passed to the
functions described in this section.
@menu
* Testing Accessibility:: Is a given file readable? Writable?
* Kinds of Files:: Is it a directory? A symbolic link?

89
lisp/ChangeLog
View file

@ -1,3 +1,92 @@
2013-08-25 Alan Mackenzie <acm@muc.de>
Parse C++ inher-intro when there's a template split over 2 lines.
* progmodes/cc-engine.el (c-guess-basic-syntax CASE 5C): Code more
rigorously the search for "class" etc. followed by ":".
* progmodes/cc-langs.el (c-opt-<>-sexp-key): Make the value for
random languages a regexp which never matches rather than nil.
Handle "/"s more accurately in test for virtual semicolons (AWK Mode).
* progmodes/cc-awk.el (c-awk-one-line-possibly-open-string-re)
(c-awk-regexp-one-line-possibly-open-char-list-re)
(c-awk-one-line-possibly-open-regexp-re)
(c-awk-one-line-non-syn-ws*-re): Remove.
(c-awk-possibly-open-string-re, c-awk-non-/-syn-ws*-re)
(c-awk-space*-/-re, c-awk-space*-regexp-/-re)
(c-awk-space*-unclosed-regexp-/-re): New constants.
(c-awk-at-vsemi-p): Reformulate better to recognize "/"s which
aren't regexp delimiters.
* progmodes/cc-engine.el (c-crosses-statement-barrier-p): Add in
handling for a rare situation in AWK Mode involving unterminated
strings/regexps.
2013-08-23 Glenn Morris <rgm@gnu.org>
* files.el (auto-mode-alist): Use sh-mode for .bash_history.
* files.el (interpreter-mode-alist): Use tcl-mode for expect scripts.
* files.el (create-file-buffer): If the result would begin with
spaces, prepend a "|" instead of removing them. (Bug#15162)
2013-08-23 Stefan Monnier <monnier@iro.umontreal.ca>
* textmodes/fill.el (fill-match-adaptive-prefix): Don't throw away
text-properties (bug#15155).
* calc/calc-keypd.el (calc-keypad-execute): `x-flush-mouse-queue' doesn't
exist any more.
(calc-keypad-redraw): Remove unused var `pad'.
(calc-keypad-press): Remove unused var `menu'.
2013-08-23 Martin Rudalics <rudalics@gmx.at>
* window.el (display-buffer-pop-up-frame):
Call pop-up-frame-function with BUFFER current so `make-frame' will
use it as the new frame's buffer (Bug#15133).
2013-08-22 Stefan Monnier <monnier@iro.umontreal.ca>
* calendar/timeclock.el: Minor cleanups.
(timeclock-ask-before-exiting, timeclock-use-display-time):
Use `symbol'.
(timeclock-modeline-display): Define as alias before the
actual definition.
(timeclock-mode-line-display): Use define-minor-mode.
(timeclock-day-list-template): Make it a function, add an argument.
(timeclock-day-list-required, timeclock-day-list-length)
(timeclock-day-list-debt, timeclock-day-list-span)
(timeclock-day-list-break): Adjust calls accordingly.
2013-08-21 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/pp.el (pp-eval-expression, pp-macroexpand-expression):
Use read--expression so that completion works again.
2013-08-21 Sam Steingold <sds@gnu.org>
Add rudimentary inferior shell interaction
* progmodes/sh-script.el (sh-shell-process): New buffer-local variable.
(sh-set-shell): Reset it.
(sh-show-shell, sh-cd-here, sh-send-line-or-region-and-step):
New commands (bound to C-c C-z, C-c C-d, and C-c C-n).
2013-08-20 Stefan Monnier <monnier@iro.umontreal.ca>
* align.el: Use lexical-binding.
(align-region): Simplify accordingly.
2013-08-20 Michael Albinus <michael.albinus@gmx.de>
* minibuffer.el (completion--sifn-requote): Bind `non-essential'.
* rfn-eshadow.el (rfn-eshadow-update-overlay): Move binding of
`non-essential' up.
2013-08-17 Michael Albinus <michael.albinus@gmx.de>
* net/tramp.el:

369
lisp/align.el
View file

@ -1,4 +1,4 @@
;;; align.el --- align text to a specific column, by regexp
;;; align.el --- align text to a specific column, by regexp -*- lexical-binding:t -*-
;; Copyright (C) 1999-2013 Free Software Foundation, Inc.
@ -1325,7 +1325,7 @@ aligner would have dealt with are."
(unless (or (and modes (not (memq major-mode
(eval (cdr modes)))))
(and run-if (not (funcall (cdr run-if)))))
(let* ((current-case-fold case-fold-search)
(let* ((case-fold-search case-fold-search)
(case-fold (assq 'case-fold rule))
(regexp (cdr (assq 'regexp rule)))
(regfunc (and (functionp regexp) regexp))
@ -1403,215 +1403,202 @@ aligner would have dealt with are."
;; reports back that the region is ok, then align it.
(when (or (not func)
(funcall func beg end rule))
(unwind-protect
(let (rule-beg exclude-areas)
;; determine first of all where the exclusions
;; lie in this region
(when exclude-rules
;; guard against a problem with recursion and
;; dynamic binding vs. lexical binding, since
;; the call to `align-region' below will
;; re-enter this function, and rebind
;; `exclude-areas'
(set (setq exclude-areas
(make-symbol "align-exclude-areas"))
nil)
(align-region
beg end 'entire
exclude-rules nil
`(lambda (b e mode)
(or (and mode (listp mode))
(set (quote ,exclude-areas)
(cons (cons b e)
,exclude-areas)))))
(setq exclude-areas
(sort (symbol-value exclude-areas)
(function
(lambda (l r)
(>= (car l) (car r)))))))
(let (rule-beg exclude-areas)
;; determine first of all where the exclusions
;; lie in this region
(when exclude-rules
(align-region
beg end 'entire
exclude-rules nil
(lambda (b e mode)
(or (and mode (listp mode))
(setq exclude-areas
(cons (cons b e)
exclude-areas)))))
(setq exclude-areas
(nreverse
(sort exclude-areas #'car-less-than-car))))
;; set `case-fold-search' according to the
;; (optional) `case-fold' property
(and case-fold
(setq case-fold-search (cdr case-fold)))
;; set `case-fold-search' according to the
;; (optional) `case-fold' property
(and case-fold
(setq case-fold-search (cdr case-fold)))
;; while we can find the rule in the alignment
;; region..
(while (and (< (point) end-mark)
(setq search-start (point))
(if regfunc
(funcall regfunc end-mark nil)
(re-search-forward regexp
end-mark t)))
;; while we can find the rule in the alignment
;; region..
(while (and (< (point) end-mark)
(setq search-start (point))
(if regfunc
(funcall regfunc end-mark nil)
(re-search-forward regexp
end-mark t)))
;; give the user some indication of where we
;; are, if it's a very large region being
;; aligned
(if report
(let ((symbol (car rule)))
(if (and symbol (symbolp symbol))
(message
"Aligning `%s' (rule %d of %d) %d%%..."
(symbol-name symbol) rule-index rule-count
(/ (* (- (point) real-beg) 100)
(- end-mark real-beg)))
(message
"Aligning %d%%..."
(/ (* (- (point) real-beg) 100)
(- end-mark real-beg))))))
;; give the user some indication of where we
;; are, if it's a very large region being
;; aligned
(if report
(let ((symbol (car rule)))
(if (and symbol (symbolp symbol))
(message
"Aligning `%s' (rule %d of %d) %d%%..."
(symbol-name symbol) rule-index rule-count
(/ (* (- (point) real-beg) 100)
(- end-mark real-beg)))
(message
"Aligning %d%%..."
(/ (* (- (point) real-beg) 100)
(- end-mark real-beg))))))
;; if the search ended us on the beginning of
;; the next line, move back to the end of the
;; previous line.
(if (and (bolp) (> (point) search-start))
(forward-char -1))
;; if the search ended us on the beginning of
;; the next line, move back to the end of the
;; previous line.
(if (and (bolp) (> (point) search-start))
(forward-char -1))
;; lookup the `group' attribute the first time
;; that we need it
(unless group-c
(setq groups (or (cdr (assq 'group rule)) 1))
(unless (listp groups)
(setq groups (list groups)))
(setq first (car groups)))
;; lookup the `group' attribute the first time
;; that we need it
(unless group-c
(setq groups (or (cdr (assq 'group rule)) 1))
(unless (listp groups)
(setq groups (list groups)))
(setq first (car groups)))
(unless spacing-c
(setq spacing (cdr (assq 'spacing rule))
spacing-c t))
(unless spacing-c
(setq spacing (cdr (assq 'spacing rule))
spacing-c t))
(unless tab-stop-c
(setq tab-stop
(let ((rule-ts (assq 'tab-stop rule)))
(cond (rule-ts
(cdr rule-ts))
((symbolp align-to-tab-stop)
(symbol-value align-to-tab-stop))
(t
align-to-tab-stop)))
tab-stop-c t))
(unless tab-stop-c
(setq tab-stop
(let ((rule-ts (assq 'tab-stop rule)))
(cond (rule-ts
(cdr rule-ts))
((symbolp align-to-tab-stop)
(symbol-value align-to-tab-stop))
(t
align-to-tab-stop)))
tab-stop-c t))
;; test whether we have found a match on the same
;; line as a previous match
(when (> (point) eol)
(setq same nil)
(align--set-marker eol (line-end-position)))
;; test whether we have found a match on the same
;; line as a previous match
(when (> (point) eol)
(setq same nil)
(align--set-marker eol (line-end-position)))
;; lookup the `repeat' attribute the first time
(or repeat-c
(setq repeat (cdr (assq 'repeat rule))
repeat-c t))
;; lookup the `repeat' attribute the first time
(or repeat-c
(setq repeat (cdr (assq 'repeat rule))
repeat-c t))
;; lookup the `valid' attribute the first time
(or valid-c
(setq valid (assq 'valid rule)
valid-c t))
;; lookup the `valid' attribute the first time
(or valid-c
(setq valid (assq 'valid rule)
valid-c t))
;; remember the beginning position of this rule
;; match, and save the match-data, since either
;; the `valid' form, or the code that searches for
;; section separation, might alter it
(setq rule-beg (match-beginning first)
save-match-data (match-data))
;; remember the beginning position of this rule
;; match, and save the match-data, since either
;; the `valid' form, or the code that searches for
;; section separation, might alter it
(setq rule-beg (match-beginning first)
save-match-data (match-data))
(or rule-beg
(error "No match for subexpression %s" first))
(or rule-beg
(error "No match for subexpression %s" first))
;; unless the `valid' attribute is set, and tells
;; us that the rule is not valid at this point in
;; the code..
(unless (and valid (not (funcall (cdr valid))))
;; unless the `valid' attribute is set, and tells
;; us that the rule is not valid at this point in
;; the code..
(unless (and valid (not (funcall (cdr valid))))
;; look to see if this match begins a new
;; section. If so, we should align what we've
;; collected so far, and then begin collecting
;; anew for the next alignment section
(when (and last-point
(align-new-section-p last-point rule-beg
thissep))
(align-regions regions align-props rule func)
(setq regions nil)
(setq align-props nil))
(align--set-marker last-point rule-beg t)
;; look to see if this match begins a new
;; section. If so, we should align what we've
;; collected so far, and then begin collecting
;; anew for the next alignment section
(when (and last-point
(align-new-section-p last-point rule-beg
thissep))
(align-regions regions align-props rule func)
(setq regions nil)
(setq align-props nil))
(align--set-marker last-point rule-beg t)
;; restore the match data
(set-match-data save-match-data)
;; restore the match data
(set-match-data save-match-data)
;; check whether the region to be aligned
;; straddles an exclusion area
(let ((excls exclude-areas))
(setq exclude-p nil)
(while excls
(if (and (< (match-beginning (car groups))
(cdar excls))
(> (match-end (car (last groups)))
(caar excls)))
(setq exclude-p t
excls nil)
(setq excls (cdr excls)))))
;; check whether the region to be aligned
;; straddles an exclusion area
(let ((excls exclude-areas))
(setq exclude-p nil)
(while excls
(if (and (< (match-beginning (car groups))
(cdar excls))
(> (match-end (car (last groups)))
(caar excls)))
(setq exclude-p t
excls nil)
(setq excls (cdr excls)))))
;; go through the parenthesis groups
;; matching whitespace to be contracted or
;; expanded (or possibly justified, if the
;; `justify' attribute was set)
(unless exclude-p
(dolist (g groups)
;; We must use markers, since
;; `align-areas' may modify the buffer.
;; Avoid polluting the markers.
(let* ((group-beg (copy-marker
(match-beginning g) t))
(group-end (copy-marker
(match-end g) t))
(region (cons group-beg group-end))
(props (cons (if (listp spacing)
(car spacing)
spacing)
(if (listp tab-stop)
(car tab-stop)
tab-stop))))
(push group-beg markers)
(push group-end markers)
(setq index (if same (1+ index) 0))
(cond
((nth index regions)
(setcar (nthcdr index regions)
(cons region
(nth index regions))))
(regions
(nconc regions
(list (list region)))
(nconc align-props (list props)))
(t
(setq regions
(list (list region)))
(setq align-props (list props)))))
;; If any further rule matches are found
;; before `eol', they are on the same
;; line as this one; this can only
;; happen if the `repeat' attribute is
;; non-nil.
(if (listp spacing)
(setq spacing (cdr spacing)))
(if (listp tab-stop)
(setq tab-stop (cdr tab-stop)))
(setq same t))
;; go through the parenthesis groups
;; matching whitespace to be contracted or
;; expanded (or possibly justified, if the
;; `justify' attribute was set)
(unless exclude-p
(dolist (g groups)
;; We must use markers, since
;; `align-areas' may modify the buffer.
;; Avoid polluting the markers.
(let* ((group-beg (copy-marker
(match-beginning g) t))
(group-end (copy-marker
(match-end g) t))
(region (cons group-beg group-end))
(props (cons (if (listp spacing)
(car spacing)
spacing)
(if (listp tab-stop)
(car tab-stop)
tab-stop))))
(push group-beg markers)
(push group-end markers)
(setq index (if same (1+ index) 0))
(cond
((nth index regions)
(setcar (nthcdr index regions)
(cons region
(nth index regions))))
(regions
(nconc regions
(list (list region)))
(nconc align-props (list props)))
(t
(setq regions
(list (list region)))
(setq align-props (list props)))))
;; If any further rule matches are found
;; before `eol', they are on the same
;; line as this one; this can only
;; happen if the `repeat' attribute is
;; non-nil.
(if (listp spacing)
(setq spacing (cdr spacing)))
(if (listp tab-stop)
(setq tab-stop (cdr tab-stop)))
(setq same t))
;; if `repeat' has not been set, move to
;; the next line; don't bother searching
;; anymore on this one
(if (and (not repeat) (not (bolp)))
(forward-line))
;; if `repeat' has not been set, move to
;; the next line; don't bother searching
;; anymore on this one
(if (and (not repeat) (not (bolp)))
(forward-line))
;; if the search did not change point,
;; move forward to avoid an infinite loop
(if (= (point) search-start)
(forward-char)))))
;; if the search did not change point,
;; move forward to avoid an infinite loop
(if (= (point) search-start)
(forward-char)))))
;; when they are no more matches for this rule,
;; align whatever was left over
(if regions
(align-regions regions align-props rule func)))
(setq case-fold-search current-case-fold)))))))
;; when they are no more matches for this rule,
;; align whatever was left over
(if regions
(align-regions regions align-props rule func))))))))
(setq rules (cdr rules)
rule-index (1+ rule-index)))
;; This function can use a lot of temporary markers, so instead of

17
lisp/calc/calc-keypd.el
View file

@ -349,8 +349,7 @@
(if (> (length (car key)) cwid)
(substring (car key) 0 cwid)
(car key))))
(wid (length name))
(pad (- cwid (/ wid 2))))
(wid (length name)))
(insert (make-string (/ (- cwid wid) 2) 32)
name
(make-string (/ (- cwid wid -1) 2) 32)
@ -399,7 +398,6 @@
inv calc-inverse-flag)
calc-hyperbolic-flag))
(invhyp t)
(menu (symbol-value (nth calc-keypad-menu calc-keypad-menus)))
(input calc-keypad-input)
(iexpon (and input
(or (string-match "\\*[0-9]+\\.\\^" input)
@ -535,19 +533,22 @@
(defun calc-keypad-left-click (event)
"Handle a left-button mouse click in Calc Keypad window."
;; FIXME: Why not use "@e" instead to select the buffer?
(interactive "e")
(with-current-buffer calc-keypad-buffer
(goto-char (posn-point (event-start event)))
(calc-keypad-press)))
(defun calc-keypad-right-click (event)
(defun calc-keypad-right-click (_event)
"Handle a right-button mouse click in Calc Keypad window."
;; FIXME: Why not use "@e" instead to select the buffer?
(interactive "e")
(with-current-buffer calc-keypad-buffer
(calc-keypad-menu)))
(defun calc-keypad-middle-click (event)
(defun calc-keypad-middle-click (_event)
"Handle a middle-button mouse click in Calc Keypad window."
;; FIXME: Why not use "@e" instead to select the buffer?
(interactive "e")
(with-current-buffer calc-keypad-buffer
(calc-keypad-menu-back)))
@ -588,7 +589,6 @@
(defun calc-keypad-execute ()
(interactive)
(let* ((prompt "Calc keystrokes: ")
(flush 'x-flush-mouse-queue)
(prefix nil)
keys cmd)
(save-excursion
@ -605,10 +605,9 @@
(progn
(setq last-command-event (aref keys (1- (length keys))))
(command-execute cmd)
(setq flush 'not-any-more
prefix t
(setq prefix t
prompt (concat prompt (key-description keys) " ")))
(eq cmd flush))))) ; skip mouse-up event
nil)))) ; skip mouse-up event
(message "")
(if (commandp cmd)
(command-execute cmd)

118
lisp/calendar/timeclock.el
View file

@ -136,7 +136,7 @@ This variable only has effect if set with \\[customize]."
(if value
(add-hook 'kill-emacs-query-functions 'timeclock-query-out)
(remove-hook 'kill-emacs-query-functions 'timeclock-query-out))
(setq timeclock-ask-before-exiting value))
(set symbol value))
:type 'boolean
:group 'timeclock)
@ -174,11 +174,12 @@ a positive argument to force an update."
timeclock-update-timer)))
(setq currently-displaying nil))
(and currently-displaying
(set-variable 'timeclock-mode-line-display nil))
(setq timeclock-use-display-time value)
(setq timeclock-mode-line-display nil))
(set symbol value)
(and currently-displaying
(set-variable 'timeclock-mode-line-display t))
timeclock-use-display-time))
(setq timeclock-mode-line-display t))
;; FIXME: The return value isn't used, AFAIK!
value))
:type 'boolean
:group 'timeclock
:require 'time)
@ -269,9 +270,11 @@ The time is bracketed by <> if you are clocked in, otherwise by [].")
(define-obsolete-function-alias 'timeclock-modeline-display
'timeclock-mode-line-display "24.3")
(define-obsolete-variable-alias 'timeclock-modeline-display
'timeclock-mode-line-display "24.3")
;;;###autoload
(defun timeclock-mode-line-display (&optional arg)
(define-minor-mode timeclock-mode-line-display
"Toggle display of the amount of time left today in the mode line.
If `timeclock-use-display-time' is non-nil (the default), then
the function `display-time-mode' must be active, and the mode line
@ -280,61 +283,41 @@ the timeclock will use its own sixty second timer to do its
updating. With prefix ARG, turn mode line display on if and only
if ARG is positive. Returns the new status of timeclock mode line
display (non-nil means on)."
(interactive "P")
:global t
;; cf display-time-mode.
(setq timeclock-mode-string "")
(or global-mode-string (setq global-mode-string '("")))
(let ((on-p (if arg
(> (prefix-numeric-value arg) 0)
(not timeclock-mode-line-display))))
(if on-p
(progn
(or (memq 'timeclock-mode-string global-mode-string)
(setq global-mode-string
(append global-mode-string '(timeclock-mode-string))))
(add-hook 'timeclock-event-hook 'timeclock-update-mode-line)
(when timeclock-update-timer
(cancel-timer timeclock-update-timer)
(setq timeclock-update-timer nil))
(if (boundp 'display-time-hook)
(remove-hook 'display-time-hook 'timeclock-update-mode-line))
(if timeclock-use-display-time
(progn
;; Update immediately so there is a visible change
;; on calling this function.
(if display-time-mode
(timeclock-update-mode-line)
(message "Activate `display-time-mode' or turn off \
(if timeclock-mode-line-display
(progn
(or (memq 'timeclock-mode-string global-mode-string)
(setq global-mode-string
(append global-mode-string '(timeclock-mode-string))))
(add-hook 'timeclock-event-hook 'timeclock-update-mode-line)
(when timeclock-update-timer
(cancel-timer timeclock-update-timer)
(setq timeclock-update-timer nil))
(if (boundp 'display-time-hook)
(remove-hook 'display-time-hook 'timeclock-update-mode-line))
(if timeclock-use-display-time
(progn
;; Update immediately so there is a visible change
;; on calling this function.
(if display-time-mode
(timeclock-update-mode-line)
(message "Activate `display-time-mode' or turn off \
`timeclock-use-display-time' to see timeclock information"))
(add-hook 'display-time-hook 'timeclock-update-mode-line))
(setq timeclock-update-timer
(run-at-time nil 60 'timeclock-update-mode-line))))
(setq global-mode-string
(delq 'timeclock-mode-string global-mode-string))
(remove-hook 'timeclock-event-hook 'timeclock-update-mode-line)
(if (boundp 'display-time-hook)
(remove-hook 'display-time-hook
'timeclock-update-mode-line))
(when timeclock-update-timer
(cancel-timer timeclock-update-timer)
(setq timeclock-update-timer nil)))
(force-mode-line-update)
(setq timeclock-mode-line-display on-p)))
(define-obsolete-variable-alias 'timeclock-modeline-display
'timeclock-mode-line-display "24.3")
;; This has to be here so that the function definition of
;; `timeclock-mode-line-display' is known to the "set" function.
(defcustom timeclock-mode-line-display nil
"Toggle mode line display of time remaining.
You must modify via \\[customize] for this variable to have an effect."
:set (lambda (symbol value)
(setq timeclock-mode-line-display
(timeclock-mode-line-display (or value 0))))
:type 'boolean
:group 'timeclock
:require 'timeclock)
(add-hook 'display-time-hook 'timeclock-update-mode-line))
(setq timeclock-update-timer
(run-at-time nil 60 'timeclock-update-mode-line))))
(setq global-mode-string
(delq 'timeclock-mode-string global-mode-string))
(remove-hook 'timeclock-event-hook 'timeclock-update-mode-line)
(if (boundp 'display-time-hook)
(remove-hook 'display-time-hook
'timeclock-update-mode-line))
(when timeclock-update-timer
(cancel-timer timeclock-update-timer)
(setq timeclock-update-timer nil))))
(defsubst timeclock-time-to-date (time)
"Convert the TIME value to a textual date string."
@ -835,25 +818,24 @@ This is only provided for coherency when used by
"Return a list of all the projects in DAY."
(timeclock-entry-list-projects (cddr day)))
(defmacro timeclock-day-list-template (func)
(defun timeclock-day-list-template (func day-list)
"Template for summing the result of FUNC on each element of DAY-LIST."
`(let ((length 0))
(while day-list
(setq length (+ length (,(eval func) (car day-list)))
day-list (cdr day-list)))
length))
(let ((length 0))
(dolist (day day-list)
(setq length (+ length (funcall func day))))
length))
(defun timeclock-day-list-required (day-list)
"Return total required length of DAY-LIST, in seconds."
(timeclock-day-list-template 'timeclock-day-required))
(timeclock-day-list-template #'timeclock-day-required day-list))
(defun timeclock-day-list-length (day-list)
"Return actual length of DAY-LIST, in seconds."
(timeclock-day-list-template 'timeclock-day-length))
(timeclock-day-list-template #'timeclock-day-length day-list))
(defun timeclock-day-list-debt (day-list)
"Return total debt (required - actual) of DAY-LIST."
(timeclock-day-list-template 'timeclock-day-debt))
(timeclock-day-list-template #'timeclock-day-debt day-list))
(defsubst timeclock-day-list-begin (day-list)
"Return the start time of DAY-LIST."
@ -865,11 +847,11 @@ This is only provided for coherency when used by
(defun timeclock-day-list-span (day-list)
"Return the span of DAY-LIST."
(timeclock-day-list-template 'timeclock-day-span))
(timeclock-day-list-template #'timeclock-day-span day-list))
(defun timeclock-day-list-break (day-list)
"Return the total break of DAY-LIST."
(timeclock-day-list-template 'timeclock-day-break))
(timeclock-day-list-template #'timeclock-day-break day-list))
(defun timeclock-day-list-projects (day-list)
"Return a list of all the projects in DAY-LIST."

6
lisp/emacs-lisp/pp.el
View file

@ -127,8 +127,7 @@ after OUT-BUFFER-NAME."
"Evaluate EXPRESSION and pretty-print its value.
Also add the value to the front of the list in the variable `values'."
(interactive
(list (read-from-minibuffer "Eval: " nil read-expression-map t
'read-expression-history)))
(list (read--expression "Eval: ")))
(message "Evaluating...")
(setq values (cons (eval expression) values))
(pp-display-expression (car values) "*Pp Eval Output*"))
@ -137,8 +136,7 @@ Also add the value to the front of the list in the variable `values'."
(defun pp-macroexpand-expression (expression)
"Macroexpand EXPRESSION and pretty-print its value."
(interactive
(list (read-from-minibuffer "Macroexpand: " nil read-expression-map t
'read-expression-history)))
(list (read--expression "Macroexpand: ")))
(pp-display-expression (macroexpand expression) "*Pp Macroexpand Output*"))
(defun pp-last-sexp ()

31
lisp/erc/ChangeLog
View file

@ -1,3 +1,34 @@
2013-08-22 Stefan Monnier <monnier@iro.umontreal.ca>
* erc.el: Use lexical-binding.
(erc-user-full-name): Minor CSE simplification.
(erc-mode-map): Assume command-remapping is available.
(erc-once-with-server-event): Replace `forms' arg with a function arg.
(erc-once-with-server-event-global): Remove.
(erc-ison-p): Adjust to change in erc-once-with-server-event.
(erc-get-buffer-create): Remove arg `proc'.
(iswitchb-make-buflist-hook): Declare.
(erc-setup-buffer): Use pcase; avoid ((lambda ..) ..).
(read-passwd): Assume it exists.
(erc-display-line, erc-cmd-IDLE): Avoid add-to-list, adjust to change
in erc-once-with-server-event.
(erc-cmd-JOIN, erc-set-channel-limit, erc-set-channel-key)
(erc-add-query): Minor CSE simplification.
(erc-cmd-BANLIST, erc-cmd-MASSUNBAN): Adjust to change
in erc-once-with-server-event.
(erc-echo-notice-in-user-and-target-buffers): Avoid add-to-list.
* erc-track.el: Use lexical-binding.
(erc-make-mode-line-buffer-name): Use closures instead of `(lambda...).
(erc-faces-in): Avoid add-to-list.
* erc-notify.el: Use lexical-binding.
(erc-notify-timer): Adjust to change in erc-once-with-server-event.
(erc-notify-QUIT): Use a closure instead of `(lambda...).
* erc-list.el: Use lexical-binding.
(erc-list-install-322-handler, erc-cmd-LIST): Adjust to change in
erc-once-with-server-event.
* erc-button.el: Use lexical-binding.
(erc-button-next-function): Use a closure instead of `(lambda...).
2013-05-30 Glenn Morris <rgm@gnu.org>
* erc-backend.el: Require erc at run-time too.

31
lisp/erc/erc-button.el
View file

@ -1,4 +1,4 @@
;; erc-button.el --- A way of buttonizing certain things in ERC buffers
;; erc-button.el --- A way of buttonizing certain things in ERC buffers -*- lexical-binding:t -*-
;; Copyright (C) 1996-2004, 2006-2013 Free Software Foundation, Inc.
@ -432,19 +432,22 @@ call it with the value of the `erc-data' text property."
(defun erc-button-next-function ()
"Pseudo completion function that actually jumps to the next button.
For use on `completion-at-point-functions'."
(when (< (point) (erc-beg-of-input-line))
`(lambda ()
(let ((here ,(point)))
(while (and (get-text-property here 'erc-callback)
(not (= here (point-max))))
(setq here (1+ here)))
(while (and (not (get-text-property here 'erc-callback))
(not (= here (point-max))))
(setq here (1+ here)))
(if (< here (point-max))
(goto-char here)
(error "No next button"))
t))))
;; FIXME: This is an abuse of completion-at-point-functions.
(when (< (point) (erc-beg-of-input-line))
(let ((start (point)))
(lambda ()
(let ((here start))
;; FIXME: Use next-single-property-change.
(while (and (get-text-property here 'erc-callback)
(not (= here (point-max))))
(setq here (1+ here)))
(while (not (or (get-text-property here 'erc-callback)
(= here (point-max))))
(setq here (1+ here)))
(if (< here (point-max))
(goto-char here)
(error "No next button"))
t)))))
(defun erc-button-next ()
"Go to the next button in this buffer."

15
lisp/erc/erc-list.el
View file

@ -1,4 +1,4 @@
;;; erc-list.el --- /list support for ERC
;;; erc-list.el --- /list support for ERC -*- lexical-binding:t -*-
;; Copyright (C) 2008-2013 Free Software Foundation, Inc.
@ -183,7 +183,7 @@
;; Arrange for 323 (end of list) to end this.
(erc-once-with-server-event
323
'(progn
(lambda (_proc _parsed)
(remove-hook 'erc-server-322-functions 'erc-list-handle-322 t)))
;; Find the list buffer, empty it, and display it.
(set (make-local-variable 'erc-list-buffer)
@ -209,11 +209,12 @@ should usually be one or more channels, separated by commas.
Please note that this function only works with IRC servers which conform
to RFC and send the LIST header (#321) at start of list transmission."
(erc-with-server-buffer
(set (make-local-variable 'erc-list-last-argument) line)
(erc-once-with-server-event
321
(list 'progn
(list 'erc-list-install-322-handler (current-buffer)))))
(set (make-local-variable 'erc-list-last-argument) line)
(erc-once-with-server-event
321
(let ((buf (current-buffer)))
(lambda (_proc _parsed)
(erc-list-install-322-handler buf)))))
(erc-server-send (concat "LIST :" (or (and line (substring line 1))
""))))
(put 'erc-cmd-LIST 'do-not-parse-args t)

54
lisp/erc/erc-notify.el
View file

@ -1,4 +1,4 @@
;;; erc-notify.el --- Online status change notification
;;; erc-notify.el --- Online status change notification -*- lexical-binding:t -*-
;; Copyright (C) 2002-2004, 2006-2013 Free Software Foundation, Inc.
@ -115,27 +115,28 @@ changes."
erc-notify-interval))
(erc-once-with-server-event
303
'(let* ((server (erc-response.sender parsed))
(ison-list (delete "" (split-string
(erc-response.contents parsed))))
(new-list ison-list)
(old-list (erc-with-server-buffer erc-last-ison)))
(while new-list
(when (not (erc-member-ignore-case (car new-list) old-list))
(run-hook-with-args 'erc-notify-signon-hook server (car new-list))
(erc-display-message
parsed 'notice proc
'notify_on ?n (car new-list) ?m (erc-network-name)))
(setq new-list (cdr new-list)))
(while old-list
(when (not (erc-member-ignore-case (car old-list) ison-list))
(run-hook-with-args 'erc-notify-signoff-hook server (car old-list))
(erc-display-message
parsed 'notice proc
'notify_off ?n (car old-list) ?m (erc-network-name)))
(setq old-list (cdr old-list)))
(setq erc-last-ison ison-list)
t))
(lambda (proc parsed)
(let* ((server (erc-response.sender parsed))
(ison-list (delete "" (split-string
(erc-response.contents parsed))))
(new-list ison-list)
(old-list (erc-with-server-buffer erc-last-ison)))
(while new-list
(when (not (erc-member-ignore-case (car new-list) old-list))
(run-hook-with-args 'erc-notify-signon-hook server (car new-list))
(erc-display-message
parsed 'notice proc
'notify_on ?n (car new-list) ?m (erc-network-name)))
(setq new-list (cdr new-list)))
(while old-list
(when (not (erc-member-ignore-case (car old-list) ison-list))
(run-hook-with-args 'erc-notify-signoff-hook server (car old-list))
(erc-display-message
parsed 'notice proc
'notify_off ?n (car old-list) ?m (erc-network-name)))
(setq old-list (cdr old-list)))
(setq erc-last-ison ison-list)
t)))
(erc-server-send
(concat "ISON " (mapconcat 'identity erc-notify-list " ")))
(setq erc-last-ison-time now)))
@ -179,10 +180,11 @@ nick from `erc-last-ison' to prevent any further notifications."
(let ((nick (erc-extract-nick (erc-response.sender parsed))))
(when (and (erc-member-ignore-case nick erc-notify-list)
(erc-member-ignore-case nick erc-last-ison))
(setq erc-last-ison (erc-delete-if `(lambda (el)
(string= ,(erc-downcase nick)
(erc-downcase el)))
erc-last-ison))
(setq erc-last-ison (erc-delete-if
(let ((nick-down (erc-downcase nick)))
(lambda (el)
(string= nick-down (erc-downcase el))))
erc-last-ison))
(run-hook-with-args 'erc-notify-signoff-hook
(or erc-server-announced-name erc-session-server)
nick)

35
lisp/erc/erc-track.el
View file

@ -1,4 +1,4 @@
;;; erc-track.el --- Track modified channel buffers
;;; erc-track.el --- Track modified channel buffers -*- lexical-binding:t -*-
;; Copyright (C) 2002-2013 Free Software Foundation, Inc.
@ -710,7 +710,7 @@ inactive."
to consider when `erc-track-visibility' is set to
only consider active buffers visible.")
(defun erc-user-is-active (&rest ignore)
(defun erc-user-is-active (&rest _ignore)
"Set `erc-buffer-activity'."
(when erc-server-connected
(setq erc-buffer-activity (erc-current-time))
@ -745,7 +745,7 @@ only consider active buffers visible.")
times. Without it, you cannot debug `erc-modified-channels-display',
because the debugger also cases changes to the window-configuration.")
(defun erc-modified-channels-update (&rest args)
(defun erc-modified-channels-update (&rest _args)
"This function updates the information in `erc-modified-channels-alist'
according to buffer visibility. It calls
`erc-modified-channels-display' at the end. This should usually be
@ -791,19 +791,19 @@ If FACES are provided, color STRING with them."
(int-to-string count))
(copy-sequence string))))
(define-key map (vector 'mode-line 'mouse-2)
`(lambda (e)
(interactive "e")
(save-selected-window
(select-window
(posn-window (event-start e)))
(switch-to-buffer ,buffer))))
(lambda (e)
(interactive "e")
(save-selected-window
(select-window
(posn-window (event-start e)))
(switch-to-buffer buffer))))
(define-key map (vector 'mode-line 'mouse-3)
`(lambda (e)
(interactive "e")
(save-selected-window
(select-window
(posn-window (event-start e)))
(switch-to-buffer-other-window ,buffer))))
(lambda (e)
(interactive "e")
(save-selected-window
(select-window
(posn-window (event-start e)))
(switch-to-buffer-other-window buffer))))
(put-text-property 0 (length name) 'local-map map name)
(put-text-property
0 (length name)
@ -976,8 +976,9 @@ is in `erc-mode'."
cur)
(while (and (setq i (next-single-property-change i 'face str m))
(not (= i m)))
(when (setq cur (get-text-property i 'face str))
(add-to-list 'faces cur)))
(and (setq cur (get-text-property i 'face str))
(not (member cur faces))
(push cur faces)))
faces))
(cl-assert

593
lisp/erc/erc.el
View file

File diff suppressed because it is too large Load diff

16
lisp/files.el
View file

@ -1603,13 +1603,16 @@ killed."
"Create a suitably named buffer for visiting FILENAME, and return it.
FILENAME (sans directory) is used unchanged if that name is free;
otherwise a string <2> or <3> or ... is appended to get an unused name.
Spaces at the start of FILENAME (sans directory) are removed."
Emacs treats buffers whose names begin with a space as internal buffers.
To avoid confusion when visiting a file whose name begins with a space,
this function prepends a \"|\" to the final result if necessary."
(let ((lastname (file-name-nondirectory filename)))
(if (string= lastname "")
(setq lastname filename))
(save-match-data
(string-match "^ *\\(.*\\)" lastname)
(generate-new-buffer (match-string 1 lastname)))))
(generate-new-buffer (if (string-match-p "\\` " lastname)
(concat "|" lastname)
lastname))))
(defun generate-new-buffer (name)
"Create and return a buffer with a name based on NAME.
@ -2272,8 +2275,8 @@ since only a single case-insensitive search through the alist is made."
("\\.scm\\.[0-9]*\\'" . scheme-mode)
("\\.[ck]?sh\\'\\|\\.shar\\'\\|/\\.z?profile\\'" . sh-mode)
("\\.bash\\'" . sh-mode)
("\\(/\\|\\`\\)\\.\\(bash_profile\\|z?login\\|bash_login\\|z?logout\\)\\'" . sh-mode)
("\\(/\\|\\`\\)\\.\\(bash_logout\\|shrc\\|[kz]shrc\\|bashrc\\|t?cshrc\\|esrc\\)\\'" . sh-mode)
("\\(/\\|\\`\\)\\.\\(bash_\\(profile\\|history\\|log\\(in\\|out\\)\\)\\|z?log\\(in\\|out\\)\\)\\'" . sh-mode)
("\\(/\\|\\`\\)\\.\\(shrc\\|[kz]shrc\\|bashrc\\|t?cshrc\\|esrc\\)\\'" . sh-mode)
("\\(/\\|\\`\\)\\.\\([kz]shenv\\|xinitrc\\|startxrc\\|xsession\\)\\'" . sh-mode)
("\\.m?spec\\'" . sh-mode)
("\\.m[mes]\\'" . nroff-mode)
@ -2451,6 +2454,7 @@ and `magic-mode-alist', which determines modes based on file contents.")
("wishx" . tcl-mode)
("tcl" . tcl-mode)
("tclsh" . tcl-mode)
("expect" . tcl-mode)
("scm" . scheme-mode)
("ash" . sh-mode)
("bash" . sh-mode)

3
lisp/minibuffer.el
View file

@ -2246,7 +2246,8 @@ same as `substitute-in-file-name'."
;; - Cygwin (substitute-in-file-name "C:\bin") => "/usr/bin"
;; (substitute-in-file-name "C:\") => "/"
;; (substitute-in-file-name "C:\bi") => "/bi"
(let* ((ustr (substitute-in-file-name qstr))
(let* ((non-essential t)
(ustr (substitute-in-file-name qstr))
(uprefix (substring ustr 0 upos))
qprefix)
;; Main assumption: nothing after qpos should affect the text before upos,

81
lisp/progmodes/cc-awk.el
View file

@ -169,9 +169,9 @@
(concat "\\=_?\"" c-awk-string-innards-re))
;; Matches an AWK string at point up to, but not including, any terminator.
;; A gawk 3.1+ string may look like _"localizable string".
(defconst c-awk-one-line-possibly-open-string-re
(concat "\"\\(" c-awk-string-ch-re "\\|" c-awk-non-eol-esc-pair-re "\\)*"
"\\(\"\\|\\\\?$\\|\\'\\)"))
(defconst c-awk-possibly-open-string-re
(concat "\"\\(" c-awk-string-ch-re "\\|" c-awk-esc-pair-re "\\)*"
"\\(\"\\|$\\|\\'\\)"))
;; REGEXPS FOR AWK REGEXPS.
(defconst c-awk-regexp-normal-re "[^[/\\\n\r]")
@ -192,25 +192,13 @@
"\\|" "[^]\n\r]" "\\)*" "\\(]\\|$\\)"))
;; Matches a regexp char list, up to (but not including) EOL if the ] is
;; missing.
(defconst c-awk-regexp-one-line-possibly-open-char-list-re
(concat "\\[\\]?\\(" c-awk-non-eol-esc-pair-re "\\|" "[^]\n\r]" "\\)*"
"\\(]\\|\\\\?$\\|\\'\\)"))
;; Matches the head (or all) of a regexp char class, up to (but not
;; including) the first EOL.
(defconst c-awk-regexp-innards-re
(concat "\\(" c-awk-esc-pair-re "\\|" c-awk-regexp-char-list-re
"\\|" c-awk-regexp-normal-re "\\)*"))
"\\|" c-awk-regexp-normal-re "\\)*"))
;; Matches the inside of an AWK regexp (i.e. without the enclosing /s)
(defconst c-awk-regexp-without-end-re
(concat "/" c-awk-regexp-innards-re))
;; Matches an AWK regexp up to, but not including, any terminating /.
(defconst c-awk-one-line-possibly-open-regexp-re
(concat "/\\(" c-awk-non-eol-esc-pair-re
"\\|" c-awk-regexp-one-line-possibly-open-char-list-re
"\\|" c-awk-regexp-normal-re "\\)*"
"\\(/\\|\\\\?$\\|\\'\\)"))
;; Matches as much of the head of an AWK regexp which fits on one line,
;; possibly all of it.
;; REGEXPS used for scanning an AWK buffer in order to decide IF A '/' IS A
;; REGEXP OPENER OR A DIVISION SIGN. By "state" in the following is meant
@ -262,15 +250,24 @@
;; REGEXPS USED FOR FINDING THE POSITION OF A "virtual semicolon"
(defconst c-awk-_-harmless-nonws-char-re "[^#/\"\\\\\n\r \t]")
;; NEW VERSION! (which will be restricted to the current line)
(defconst c-awk-one-line-non-syn-ws*-re
(concat "\\([ \t]*"
"\\(" c-awk-_-harmless-nonws-char-re "\\|"
c-awk-non-eol-esc-pair-re "\\|"
c-awk-one-line-possibly-open-string-re "\\|"
c-awk-one-line-possibly-open-regexp-re
"\\)"
"\\)*"))
(defconst c-awk-non-/-syn-ws*-re
(concat
"\\(" c-awk-escaped-nls*-with-space*
"\\(" c-awk-_-harmless-nonws-char-re "\\|"
c-awk-non-eol-esc-pair-re "\\|"
c-awk-possibly-open-string-re
"\\)"
"\\)*"))
(defconst c-awk-space*-/-re (concat c-awk-escaped-nls*-with-space* "/"))
;; Matches optional whitespace followed by "/".
(defconst c-awk-space*-regexp-/-re
(concat c-awk-escaped-nls*-with-space* "\\s\""))
;; Matches optional whitespace followed by a "/" with string syntax (a matched
;; regexp delimiter).
(defconst c-awk-space*-unclosed-regexp-/-re
(concat c-awk-escaped-nls*-with-space* "\\s\|"))
;; Matches optional whitespace followed by a "/" with string fence syntax (an
;; unmatched regexp delimiter).
;; ACM, 2002/5/29:
@ -549,10 +546,36 @@
(defun c-awk-at-vsemi-p (&optional pos)
;; Is there a virtual semicolon at POS (or POINT)?
(save-excursion
(let (nl-prop
(pos-or-point (progn (if pos (goto-char pos)) (point))))
(forward-line 0)
(search-forward-regexp c-awk-one-line-non-syn-ws*-re)
(let* (nl-prop
(pos-or-point (progn (if pos (goto-char pos)) (point)))
(bol (c-point 'bol)) (eol (c-point 'eol)))
(c-awk-beginning-of-logical-line)
;; Next `while' goes round one logical line (ending in, e.g. "\\") per
;; iteration. Such a line is rare, and can only be an open string
;; ending in an escaped \.
(while
(progn
;; Next `while' goes over a division sign or /regexp/ per iteration.
(while
(and
(< (point) eol)
(progn
(search-forward-regexp c-awk-non-/-syn-ws*-re eol)
(looking-at c-awk-space*-/-re)))
(cond
((looking-at c-awk-space*-regexp-/-re) ; /regexp/
(forward-sexp))
((looking-at c-awk-space*-unclosed-regexp-/-re) ; Unclosed /regexp
(condition-case nil
(progn
(forward-sexp)
(backward-char)) ; Move to end of (logical) line.
(error (end-of-line)))) ; Happens at EOB.
(t ; division sign
(c-forward-syntactic-ws)
(forward-char))))
(< (point) bol))
(forward-line))
(and (eq (point) pos-or-point)
(progn
(while (and (eq (setq nl-prop (c-awk-get-NL-prop-cur-line)) ?\\)

15
lisp/progmodes/cc-engine.el
View file

@ -1271,6 +1271,9 @@ comment at the start of cc-engine.el for more info."
(throw 'done (point)))))
;; In trailing space after an as yet undetected virtual semicolon?
(c-backward-syntactic-ws from)
(when (and (bolp) (not (bobp))) ; Can happen in AWK Mode with an
; unterminated string/regexp.
(backward-char))
(if (and (< (point) to)
(c-at-vsemi-p))
(point)
@ -9796,12 +9799,12 @@ comment at the start of cc-engine.el for more info."
(not (eq (char-after) ?:))
)))
(save-excursion
(c-backward-syntactic-ws lim)
(if (eq char-before-ip ?:)
(progn
(forward-char -1)
(c-backward-syntactic-ws lim)))
(back-to-indentation)
(c-beginning-of-statement-1 lim)
(when (looking-at c-opt-<>-sexp-key)
(goto-char (match-end 1))
(c-forward-syntactic-ws)
(c-forward-<>-arglist nil)
(c-forward-syntactic-ws))
(looking-at c-class-key)))
;; for Java
(and (c-major-mode-is 'java-mode)

3
lisp/progmodes/cc-langs.el
View file

@ -2163,8 +2163,7 @@ assumed to be set if this isn't nil."
(c-lang-defconst c-opt-<>-sexp-key
;; Adorned regexp matching keywords that can be followed by an angle
;; bracket sexp. Always set when `c-recognize-<>-arglists' is.
t (if (c-lang-const c-recognize-<>-arglists)
(c-make-keywords-re t (c-lang-const c-<>-sexp-kwds))))
t (c-make-keywords-re t (c-lang-const c-<>-sexp-kwds)))
(c-lang-defvar c-opt-<>-sexp-key (c-lang-const c-opt-<>-sexp-key))
(c-lang-defconst c-brace-id-list-kwds

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

@ -497,6 +497,9 @@ This is buffer-local in every such buffer.")
(define-key map "\C-c+" 'sh-add)
(define-key map "\C-\M-x" 'sh-execute-region)
(define-key map "\C-c\C-x" 'executable-interpret)
(define-key map "\C-c\C-n" 'sh-send-line-or-region-and-step)
(define-key map "\C-c\C-d" 'sh-cd-here)
(define-key map "\C-c\C-z" 'sh-show-shell)
(define-key map [remap delete-backward-char]
'backward-delete-char-untabify)
@ -1461,6 +1464,61 @@ command `sh-make-vars-local'.
The default is t because I assume that in one Emacs session one is
frequently editing existing scripts with different styles.")
;; inferior shell interaction
;; TODO: support multiple interactive shells
(defvar sh-shell-process nil
"The inferior shell process for interaction.")
(make-variable-buffer-local 'sh-shell-process)
(defun sh-shell-process (force)
"Get a shell process for interaction.
If FORCE is non-nil and no process found, create one."
(if (and sh-shell-process (process-live-p sh-shell-process))
sh-shell-process
(setq sh-shell-process
(let ((found nil) proc
(procs (process-list)))
(while (and (not found) procs
(process-live-p (setq proc (pop procs)))
(process-command proc))
(when (string-equal sh-shell (file-name-nondirectory
(car (process-command proc))))
(setq found proc)))
(or found
(and force
(get-buffer-process
(let ((explicit-shell-file-name sh-shell-file))
(shell)))))))))
(defun sh-show-shell ()
"Pop the shell interaction buffer."
(interactive)
(pop-to-buffer (process-buffer (sh-shell-process t))))
(defun sh-send-text (text)
"Send the text to the `sh-shell-process'."
(comint-send-string (sh-shell-process t) (concat text "\n")))
(defun sh-cd-here ()
"Change directory in the current interaction shell to the current one."
(interactive)
(sh-send-text (concat "cd " default-directory)))
(defun sh-send-line-or-region-and-step ()
"Send the current line to the inferior shell and step to the next line.
When the region is active, send the region instead."
(interactive)
(let (from to end)
(if (use-region-p)
(setq from (region-beginning)
to (region-end)
end to)
(setq from (line-beginning-position)
to (line-end-position)
end (1+ to)))
(sh-send-text (buffer-substring-no-properties from to))
(goto-char end)))
;; mode-command and utility functions
@ -2169,6 +2227,7 @@ Calls the value of `sh-set-shell-hook' if set."
(setq font-lock-set-defaults nil)
(font-lock-set-defaults)
(font-lock-fontify-buffer))
(setq sh-shell-process nil)
(run-hooks 'sh-set-shell-hook))

10
lisp/rfn-eshadow.el
View file

@ -176,11 +176,11 @@ This is intended to be used as a minibuffer `post-command-hook' for
`file-name-shadow-mode'; the minibuffer should have already
been set up by `rfn-eshadow-setup-minibuffer'."
(condition-case nil
(let ((goal (substitute-in-file-name (minibuffer-contents)))
(mid (overlay-end rfn-eshadow-overlay))
(start (minibuffer-prompt-end))
(end (point-max))
(non-essential t))
(let* ((non-essential t)
(goal (substitute-in-file-name (minibuffer-contents)))
(mid (overlay-end rfn-eshadow-overlay))
(start (minibuffer-prompt-end))
(end (point-max)))
(unless
;; Catch the common case where the shadow does not need to move.
(and mid

2
lisp/textmodes/fill.el
View file

@ -220,7 +220,7 @@ Remove indentation from each line."
(let ((str (or
(and adaptive-fill-function (funcall adaptive-fill-function))
(and adaptive-fill-regexp (looking-at adaptive-fill-regexp)
(match-string-no-properties 0)))))
(match-string 0)))))
(if (>= (+ (current-left-margin) (length str)) (current-fill-column))
;; Death to insanely long prefixes.
nil

5
lisp/window.el
View file

@ -5642,7 +5642,10 @@ new frame."
(fun pop-up-frame-function)
frame window)
(when (and fun
(setq frame (funcall fun))
;; Make BUFFER current so `make-frame' will use it as the
;; new frame's buffer (Bug#15133).
(with-current-buffer buffer
(setq frame (funcall fun)))
(setq window (frame-selected-window frame)))
(prog1 (window--display-buffer
buffer window 'frame alist display-buffer-mark-dedicated)

14
nt/ChangeLog
View file

@ -1,7 +1,17 @@
2013-08-25 Vincent Belaïche <vincentb1@users.sourceforge.net>
* configure.bat: Rather than disabling, make configure.bat produce
some warning that building with configure.bat is deprecated and
ask for confirmation to continue.
2013-08-25 Glenn Morris <rgm@gnu.org>
* INSTALL: Refer to INSTALL.MSYS.
* configure.bat: Disable it.
2013-08-04 Eli Zaretskii <eliz@gnu.org>
* mingw-cfg.site (ac_cv_func_mkostemp): New var with value of
"yes".
* mingw-cfg.site (ac_cv_func_mkostemp): New var with value of "yes".
* inc/ms-w32.h (mkostemp): Declare prototype.
(mktemp): Don't redirect to sys_mktemp.

3
nt/INSTALL
View file

@ -4,6 +4,9 @@
Copyright (C) 2001-2013 Free Software Foundation, Inc.
See the end of the file for license conditions.
*** This method of building Emacs is no longer supported. ***
Instead, see INSTALL.MSYS.
* For the impatient
Here are the concise instructions for configuring and building the

13
nt/configure.bat
View file

@ -58,7 +58,20 @@ rem look for "cygpath" near line 85 of gmake.defs.
rem [7] not recommended; please report if you try this combination.
rem [8] tested only on Windows XP.
rem
echo ****************************************************************
echo *** THIS METHOD OF BUILDING EMACS IS NO LONGER SUPPORTED. **
echo *** INSTEAD, FOLLOW THE INSTRUCTIONS FROM INSTALL.MSYS. **
echo ****************************************************************
:confirm_continue
set /p answer=Continue running this script at your own risks ? (Y/N)
if x%answer% == xy (goto confirm_continue_y)
if x%answer% == xY (goto confirm_continue_y)
if x%answer% == xn (goto end)
if x%answer% == xN (goto end)
echo Please answer by Y or N
goto confirm_continue
:confirm_continue_y
if exist config.log del config.log
rem ----------------------------------------------------------------------

121
src/ChangeLog
View file

@ -1,3 +1,124 @@
2013-08-24 Eli Zaretskii <eliz@gnu.org>
* xdisp.c (get_next_display_element): Don't apply to characters
from a display vector the logic of setting it->end_of_box_run_p
suitable for characters from a buffer. (Bug#15175)
* w32.c (fdutimens): Call 'utime', which is implemented on w32.c
to handle directories, rather than '_utime' which doesn't.
(Bug#15176)
2013-08-24 Jan Djärv <jan.h.d@swipnet.se>
* gtkutil.c (x_wm_set_size_hint): Don't set hints when maximized
or fullscreen (Bug#14627).
2013-08-24 Paul Eggert <eggert@cs.ucla.edu>
System-dependent integer overflow fixes.
* process.c (Fset_process_window_size): Signal an error if
the window size is outside the range supported by the lower level.
* sysdep.c (set_window_size): Return negative on error,
nonnegative on success, rather than -1, 0, 1 on not in system,
failure, success. This is simpler. Caller changed.
(serial_configure): Remove unnecessary initialization of local.
(procfs_get_total_memory) [GNU_LINUX]: Don't assume system memory
size fits in unsigned long; this isn't true on some 32-bit hosts.
Avoid buffer overrun if some future version of /proc/meminfo has a
variable name longer than 20 bytes.
(system_process_attributes) [__FreeBSD__]:
Don't assume hw.availpages fits in 'int'.
2013-08-23 Paul Eggert <eggert@cs.ucla.edu>
Don't let very long directory names overrun the stack.
Fix some related minor problems involving "//", vfork.
* callproc.c (encode_current_directory): New function.
(call_process): Don't append "/"; not needed.
* fileio.c (file_name_as_directory_slop): New constant.
(file_name_as_directory): Allow SRC to be longer than SRCLEN;
this can save the caller having to alloca.
(Ffile_name_as_directory, Fdirectory_file_name, Fexpand_file_name):
Use SAFE_ALLOCA, not alloca.
(directory_file_name, Fexpand_file_name): Leave leading "//"
alone, since it can be special even on POSIX platforms.
* callproc.c (call_process):
* process.c (Fformat_network_address):
* sysdep.c (sys_subshell):
Use encode_current_directory rather than rolling our own.
(create_process): No need to encode directory; caller does that now.
* process.h (encode_current_directory): New decl.
* sysdep.c (sys_subshell): Work even if vfork trashes saved_handlers.
Rework to avoid 'goto xyzzy;'.
2013-08-23 Eli Zaretskii <eliz@gnu.org>
* xdisp.c (handle_face_prop): If the default face was remapped use
the remapped face for strings from prefix properties. (Bug#15155)
2013-08-23 Dmitry Antipov <dmantipov@yandex.ru>
Minor cleanup for redisplay interface and few related functions.
* frame.h (enum text_cursor_kinds): Move from here...
* dispextern.h (enum text_cursor_kinds): ...to here.
(toplevel): Drop unnecessary declarations.
(struct redisplay_interface): Use bool and enum text_cursor_kinds
in update_window_end_hook and draw_window_cursor functions.
(display_and_set_cursor, x_update_cursor): Adjust prototypes.
* nsterm.m (ns_update_window_end, ns_draw_window_cursor):
* w32term.c (x_update_window_end,w32_draw_window_cursor):
* xterm.c (x_update_window_end, x_draw_window_cursor):
* xdisp.c (display_and_set_cursor, update_window_cursor)
(update_cursor_in_window_tree, x_update_cursor): Use bool and
enum text_cursor_kinds where appropriate.
2013-08-23 Dmitry Antipov <dmantipov@yandex.ru>
Redesign redisplay interface to drop updated_row and updated_area.
* dispextern.h (updated_row, updated_area): Remove declaration.
(struct redisplay_interface): Pass glyph row and row area parameters
to write_glyphs, insert_glyphs and clear_end_of_line functions.
(x_write_glyphs, x_insert_glyphs, x_clear_end_of_line):
Adjust prototypes.
* dispnew.c (updated_row, updated_area): Remove.
(redraw_overlapped_rows, update_window_line): Adjust user.
(update_marginal_area, update_text_area): Likewise. Pass updated row
as a parameter. Prefer enum glyph_row_area to int where appropriate.
* xdisp.c (x_write_glyphs, x_insert_glyphs, x_clear_end_of_line):
Adjust users.
2013-08-22 Paul Eggert <eggert@cs.ucla.edu>
* process.c (flush_pending_output): Remove stub.
All uses removed.
2013-08-21 Paul Eggert <eggert@cs.ucla.edu>
* callproc.c: Fix race that killed background processes (Bug#15144).
(call_process): New arg TEMPFILE_INDEX. Callers changed.
Record deleted process-id in critical section, not afterwards.
Don't mistakenly kill process created by a call-process invocation
that discards output and does not wait.
2013-08-21 Dmitry Antipov <dmantipov@yandex.ru>
Fix compilation with GC_MARK_STACK == GC_USE_GCPROS_AS_BEFORE
and GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES.
* alloc.c (toplevel): Remove unnecessary nested #if...#endif.
(mark_maybe_object) [!GC_MARK_STACK]: Define to emacs_abort
to shut up compiler in mark_object.
(dump_zombies): Convert to global and add EXTERNALLY_VISIBLE.
2013-08-21 Paul Eggert <eggert@cs.ucla.edu>
* process.c (allocate_pty) [PTY_OPEN]: Set fd's FD_CLOEXEC flag.
We can't portably rely on PTY_OPEN doing that, even if
it calls posix_openpt with O_CLOEXEC.
2013-08-20 Kenichi Handa <handa@gnu.org>
* character.c (string_char): Improve commentary.
2013-08-20 Paul Eggert <eggert@cs.ucla.edu>
* image.c (SIGNATURE_DIGESTSIZE): Remove.

12
src/alloc.c
View file

@ -314,7 +314,6 @@ static void *min_heap_address, *max_heap_address;
static struct mem_node mem_z;
#define MEM_NIL &mem_z
#if GC_MARK_STACK || defined GC_MALLOC_CHECK
static struct mem_node *mem_insert (void *, void *, enum mem_type);
static void mem_insert_fixup (struct mem_node *);
static void mem_rotate_left (struct mem_node *);
@ -322,7 +321,6 @@ static void mem_rotate_right (struct mem_node *);
static void mem_delete (struct mem_node *);
static void mem_delete_fixup (struct mem_node *);
static struct mem_node *mem_find (void *);
#endif
#endif /* GC_MARK_STACK || GC_MALLOC_CHECK */
@ -4237,6 +4235,10 @@ live_buffer_p (struct mem_node *m, void *p)
#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
/* Currently not used, but may be called from gdb. */
void dump_zombies (void) EXTERNALLY_VISIBLE;
/* Array of objects that are kept alive because the C stack contains
a pattern that looks like a reference to them . */
@ -4619,7 +4621,7 @@ check_gcpros (void)
#elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
static void
void
dump_zombies (void)
{
int i;
@ -4766,6 +4768,10 @@ flush_stack_call_func (void (*func) (void *arg), void *arg)
eassert (current_thread == self);
}
#else /* GC_MARK_STACK == 0 */
#define mark_maybe_object(obj) emacs_abort ()
#endif /* GC_MARK_STACK != 0 */

104
src/callproc.c
View file

@ -102,7 +102,7 @@ enum
CALLPROC_FDS
};
static Lisp_Object call_process (ptrdiff_t, Lisp_Object *, int);
static Lisp_Object call_process (ptrdiff_t, Lisp_Object *, int, ptrdiff_t);
/* Block SIGCHLD. */
@ -123,6 +123,37 @@ unblock_child_signal (void)
pthread_sigmask (SIG_SETMASK, &empty_mask, 0);
}
/* Return the current buffer's working directory, or the home
directory if it's unreachable, as a string suitable for a system call.
Signal an error if the result would not be an accessible directory. */
Lisp_Object
encode_current_directory (void)
{
Lisp_Object dir;
struct gcpro gcpro1;
dir = BVAR (current_buffer, directory);
GCPRO1 (dir);
dir = Funhandled_file_name_directory (dir);
/* If the file name handler says that dir is unreachable, use
a sensible default. */
if (NILP (dir))
dir = build_string ("~");
dir = expand_and_dir_to_file (dir, Qnil);
if (STRING_MULTIBYTE (dir))
dir = ENCODE_FILE (dir);
if (! file_accessible_directory_p (SSDATA (dir)))
report_file_error ("Setting current directory",
BVAR (current_buffer, directory));
RETURN_UNGCPRO (dir);
}
/* If P is reapable, record it as a deleted process and kill it.
Do this in a critical section. Unless PID is wedged it will be
reaped on receipt of the first SIGCHLD after the critical section. */
@ -248,14 +279,20 @@ usage: (call-process PROGRAM &optional INFILE DESTINATION DISPLAY &rest ARGS) *
report_file_error ("Opening process input file", infile);
record_unwind_protect_int (close_file_unwind, filefd);
UNGCPRO;
return unbind_to (count, call_process (nargs, args, filefd));
return unbind_to (count, call_process (nargs, args, filefd, -1));
}
/* Like Fcall_process (NARGS, ARGS), except use FILEFD as the input file.
If TEMPFILE_INDEX is nonnegative, it is the specpdl index of an
unwinder that is intended to remove the input temporary file; in
this case NARGS must be at least 2 and ARGS[1] is the file's name.
At entry, the specpdl stack top entry must be close_file_unwind (FILEFD). */
static Lisp_Object
call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd)
call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd,
ptrdiff_t tempfile_index)
{
Lisp_Object buffer, current_dir, path;
bool display_p;
@ -402,24 +439,10 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd)
{
struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
current_dir = BVAR (current_buffer, directory);
current_dir = encode_current_directory ();
GCPRO4 (buffer, current_dir, error_file, output_file);
current_dir = Funhandled_file_name_directory (current_dir);
if (NILP (current_dir))
/* If the file name handler says that current_dir is unreachable, use
a sensible default. */
current_dir = build_string ("~/");
current_dir = expand_and_dir_to_file (current_dir, Qnil);
current_dir = Ffile_name_as_directory (current_dir);
if (NILP (Ffile_accessible_directory_p (current_dir)))
report_file_error ("Setting current directory",
BVAR (current_buffer, directory));
if (STRING_MULTIBYTE (current_dir))
current_dir = ENCODE_FILE (current_dir);
if (STRINGP (error_file) && STRING_MULTIBYTE (error_file))
error_file = ENCODE_FILE (error_file);
if (STRINGP (output_file) && STRING_MULTIBYTE (output_file))
@ -661,7 +684,22 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd)
child_errno = errno;
if (pid > 0)
synch_process_pid = pid;
{
synch_process_pid = pid;
if (INTEGERP (buffer))
{
if (tempfile_index < 0)
record_deleted_pid (pid, Qnil);
else
{
eassert (1 < nargs);
record_deleted_pid (pid, args[1]);
clear_unwind_protect (tempfile_index);
}
synch_process_pid = 0;
}
}
unblock_child_signal ();
unblock_input ();
@ -1030,7 +1068,7 @@ If you quit, the process is killed with SIGINT, or SIGKILL if you quit again.
usage: (call-process-region START END PROGRAM &optional DELETE BUFFER DISPLAY &rest ARGS) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
struct gcpro gcpro1, gcpro2;
struct gcpro gcpro1;
Lisp_Object infile, val;
ptrdiff_t count = SPECPDL_INDEX ();
Lisp_Object start = args[0];
@ -1061,8 +1099,7 @@ usage: (call-process-region START END PROGRAM &optional DELETE BUFFER DISPLAY &r
record_unwind_protect_int (close_file_unwind, fd);
}
val = infile;
GCPRO2 (infile, val);
GCPRO1 (infile);
if (nargs > 3 && !NILP (args[3]))
Fdelete_region (start, end);
@ -1079,16 +1116,7 @@ usage: (call-process-region START END PROGRAM &optional DELETE BUFFER DISPLAY &r
}
args[1] = infile;
val = call_process (nargs, args, fd);
if (!empty_input && 4 < nargs
&& (INTEGERP (CONSP (args[4]) ? XCAR (args[4]) : args[4])))
{
record_deleted_pid (synch_process_pid, infile);
synch_process_pid = 0;
clear_unwind_protect (count);
}
val = call_process (nargs, args, fd, empty_input ? -1 : count);
RETURN_UNGCPRO (unbind_to (count, val));
}
@ -1165,23 +1193,21 @@ child_setup (int in, int out, int err, char **new_argv, bool set_pgrp,
static variables as if the superior had done alloca and will be
cleaned up in the usual way. */
{
register char *temp;
size_t i; /* size_t, because ptrdiff_t might overflow here! */
char *temp;
ptrdiff_t i;
i = SBYTES (current_dir);
#ifdef MSDOS
/* MSDOS must have all environment variables malloc'ed, because
low-level libc functions that launch subsidiary processes rely
on that. */
pwd_var = xmalloc (i + 6);
pwd_var = xmalloc (i + 5);
#else
pwd_var = alloca (i + 6);
pwd_var = alloca (i + 5);
#endif
temp = pwd_var + 4;
memcpy (pwd_var, "PWD=", 4);
memcpy (temp, SDATA (current_dir), i);
if (!IS_DIRECTORY_SEP (temp[i - 1])) temp[i++] = DIRECTORY_SEP;
temp[i] = 0;
strcpy (temp, SSDATA (current_dir));
#ifndef DOS_NT
/* We can't signal an Elisp error here; we're in a vfork. Since

14
src/character.c
View file

@ -174,11 +174,14 @@ string_char (const unsigned char *p, const unsigned char **advanced, int *len)
if (*p < 0x80 || ! (*p & 0x20) || ! (*p & 0x10))
{
/* 1-, 2-, and 3-byte sequences can be handled by the macro. */
c = STRING_CHAR_ADVANCE (p);
}
else if (! (*p & 0x08))
{
c = ((((p)[0] & 0xF) << 18)
/* A 4-byte sequence of this form:
11110xxx 10xxxxxx 10xxxxxx 10xxxxxx */
c = ((((p)[0] & 0x7) << 18)
| (((p)[1] & 0x3F) << 12)
| (((p)[2] & 0x3F) << 6)
| ((p)[3] & 0x3F));
@ -186,7 +189,14 @@ string_char (const unsigned char *p, const unsigned char **advanced, int *len)
}
else
{
c = ((((p)[1] & 0x3F) << 18)
/* A 5-byte sequence of this form:
111110xx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
Note that the top 4 `x's are always 0, so shifting p[1] can
never exceed the maximum valid character codepoint. */
c = (/* (((p)[0] & 0x3) << 24) ... always 0, so no need to shift. */
(((p)[1] & 0x3F) << 18)
| (((p)[2] & 0x3F) << 12)
| (((p)[3] & 0x3F) << 6)
| ((p)[4] & 0x3F));

63
src/dispextern.h
View file

@ -95,18 +95,17 @@ typedef int Cursor;
#define NativeRectangle int
#endif
/* Structure forward declarations. Some are here because function
prototypes below reference structure types before their definition
in this file. Some are here because not every file including
dispextern.h also includes frame.h and windows.h. */
struct glyph;
struct glyph_row;
struct glyph_matrix;
struct glyph_pool;
struct frame;
struct window;
/* Text cursor types. */
enum text_cursor_kinds
{
DEFAULT_CURSOR = -2,
NO_CURSOR = -1,
FILLED_BOX_CURSOR,
HOLLOW_BOX_CURSOR,
BAR_CURSOR,
HBAR_CURSOR
};
/* Values returned from coordinates_in_window. */
@ -1197,11 +1196,6 @@ extern bool fonts_changed_p;
extern struct glyph space_glyph;
/* Glyph row and area updated by update_window_line. */
extern struct glyph_row *updated_row;
extern int updated_area;
/* Non-zero means last display completed. Zero means it was
preempted. */
@ -2713,12 +2707,17 @@ struct redisplay_interface
/* Write or insert LEN glyphs from STRING at the nominal output
position. */
void (*write_glyphs) (struct window *w, struct glyph *string, int len);
void (*insert_glyphs) (struct window *w, struct glyph *start, int len);
void (*write_glyphs) (struct window *w, struct glyph_row *row,
struct glyph *string, enum glyph_row_area area,
int len);
void (*insert_glyphs) (struct window *w, struct glyph_row *row,
struct glyph *start, enum glyph_row_area area,
int len);
/* Clear from nominal output position to X. X < 0 means clear
to right end of display. */
void (*clear_end_of_line) (struct window *w, int x);
void (*clear_end_of_line) (struct window *w, struct glyph_row *row,
enum glyph_row_area area, int x);
/* Function to call to scroll the display as described by RUN on
window W. */
@ -2739,8 +2738,8 @@ struct redisplay_interface
MOUSE_FACE_OVERWRITTEN_P non-zero means that some lines in W
that contained glyphs in mouse-face were overwritten, so we
have to update the mouse highlight. */
void (*update_window_end_hook) (struct window *w, int cursor_on_p,
int mouse_face_overwritten_p);
void (*update_window_end_hook) (struct window *w, bool cursor_on_p,
bool mouse_face_overwritten_p);
/* Move cursor to row/column position VPOS/HPOS, pixel coordinates
Y/X. HPOS/VPOS are window-relative row and column numbers and X/Y
@ -2799,10 +2798,10 @@ struct redisplay_interface
0, don't draw cursor. If ACTIVE_P is 1, system caret
should track this cursor (when applicable). */
void (*draw_window_cursor) (struct window *w,
struct glyph_row *glyph_row,
int x, int y,
int cursor_type, int cursor_width,
int on_p, int active_p);
struct glyph_row *glyph_row,
int x, int y,
enum text_cursor_kinds cursor_type,
int cursor_width, bool on_p, bool active_p);
/* Draw vertical border for window W from (X,Y_0) to (X,Y_1). */
void (*draw_vertical_window_border) (struct window *w,
@ -3178,9 +3177,12 @@ extern void x_get_glyph_overhangs (struct glyph *, struct frame *,
int *, int *);
extern void x_produce_glyphs (struct it *);
extern void x_write_glyphs (struct window *, struct glyph *, int);
extern void x_insert_glyphs (struct window *, struct glyph *, int len);
extern void x_clear_end_of_line (struct window *, int);
extern void x_write_glyphs (struct window *, struct glyph_row *,
struct glyph *, enum glyph_row_area, int);
extern void x_insert_glyphs (struct window *, struct glyph_row *,
struct glyph *, enum glyph_row_area, int);
extern void x_clear_end_of_line (struct window *, struct glyph_row *,
enum glyph_row_area, int);
extern struct cursor_pos output_cursor;
@ -3192,13 +3194,12 @@ extern void draw_phys_cursor_glyph (struct window *,
extern void get_phys_cursor_geometry (struct window *, struct glyph_row *,
struct glyph *, int *, int *, int *);
extern void erase_phys_cursor (struct window *);
extern void display_and_set_cursor (struct window *,
int, int, int, int, int);
extern void display_and_set_cursor (struct window *, bool, int, int, int, int);
extern void set_output_cursor (struct cursor_pos *);
extern void x_cursor_to (struct window *, int, int, int, int);
extern void x_update_cursor (struct frame *, int);
extern void x_update_cursor (struct frame *, bool);
extern void x_clear_cursor (struct window *);
extern void x_draw_vertical_border (struct window *w);

58
src/dispnew.c
View file

@ -135,11 +135,6 @@ struct frame *last_nonminibuf_frame;
static bool delayed_size_change;
/* Glyph row updated in update_window_line, and area that is updated. */
struct glyph_row *updated_row;
int updated_area;
/* A glyph for a space. */
struct glyph space_glyph;
@ -3230,14 +3225,12 @@ redraw_overlapped_rows (struct window *w, int yb)
for (area = LEFT_MARGIN_AREA; area < LAST_AREA; ++area)
{
updated_row = row;
updated_area = area;
FRAME_RIF (f)->cursor_to (w, i, 0, row->y,
area == TEXT_AREA ? row->x : 0);
if (row->used[area])
FRAME_RIF (f)->write_glyphs (w, row->glyphs[area],
row->used[area]);
FRAME_RIF (f)->clear_end_of_line (w, -1);
FRAME_RIF (f)->write_glyphs (w, row, row->glyphs[area],
area, row->used[area]);
FRAME_RIF (f)->clear_end_of_line (w, row, area, -1);
}
row->overlapped_p = 0;
@ -3511,22 +3504,20 @@ update_window (struct window *w, bool force_p)
AREA can be either LEFT_MARGIN_AREA or RIGHT_MARGIN_AREA. */
static void
update_marginal_area (struct window *w, int area, int vpos)
update_marginal_area (struct window *w, struct glyph_row *updated_row,
enum glyph_row_area area, int vpos)
{
struct glyph_row *desired_row = MATRIX_ROW (w->desired_matrix, vpos);
struct redisplay_interface *rif = FRAME_RIF (XFRAME (WINDOW_FRAME (w)));
/* Let functions in xterm.c know what area subsequent X positions
will be relative to. */
updated_area = area;
/* Set cursor to start of glyphs, write them, and clear to the end
of the area. I don't think that something more sophisticated is
necessary here, since marginal areas will not be the default. */
rif->cursor_to (w, vpos, 0, desired_row->y, 0);
if (desired_row->used[area])
rif->write_glyphs (w, desired_row->glyphs[area], desired_row->used[area]);
rif->clear_end_of_line (w, -1);
rif->write_glyphs (w, updated_row, desired_row->glyphs[area],
area, desired_row->used[area]);
rif->clear_end_of_line (w, updated_row, area, -1);
}
@ -3534,17 +3525,13 @@ update_marginal_area (struct window *w, int area, int vpos)
Value is true if display has changed. */
static bool
update_text_area (struct window *w, int vpos)
update_text_area (struct window *w, struct glyph_row *updated_row, int vpos)
{
struct glyph_row *current_row = MATRIX_ROW (w->current_matrix, vpos);
struct glyph_row *desired_row = MATRIX_ROW (w->desired_matrix, vpos);
struct redisplay_interface *rif = FRAME_RIF (XFRAME (WINDOW_FRAME (w)));
bool changed_p = 0;
/* Let functions in xterm.c know what area subsequent X positions
will be relative to. */
updated_area = TEXT_AREA;
/* If rows are at different X or Y, or rows have different height,
or the current row is marked invalid, write the entire line. */
if (!current_row->enabled_p
@ -3567,11 +3554,11 @@ update_text_area (struct window *w, int vpos)
rif->cursor_to (w, vpos, 0, desired_row->y, desired_row->x);
if (desired_row->used[TEXT_AREA])
rif->write_glyphs (w, desired_row->glyphs[TEXT_AREA],
desired_row->used[TEXT_AREA]);
rif->write_glyphs (w, updated_row, desired_row->glyphs[TEXT_AREA],
TEXT_AREA, desired_row->used[TEXT_AREA]);
/* Clear to end of window. */
rif->clear_end_of_line (w, -1);
rif->clear_end_of_line (w, updated_row, TEXT_AREA, -1);
changed_p = 1;
/* This erases the cursor. We do this here because
@ -3708,7 +3695,8 @@ update_text_area (struct window *w, int vpos)
}
rif->cursor_to (w, vpos, start_hpos, desired_row->y, start_x);
rif->write_glyphs (w, start, i - start_hpos);
rif->write_glyphs (w, updated_row, start,
TEXT_AREA, i - start_hpos);
changed_p = 1;
}
}
@ -3717,7 +3705,8 @@ update_text_area (struct window *w, int vpos)
if (i < desired_row->used[TEXT_AREA])
{
rif->cursor_to (w, vpos, i, desired_row->y, x);
rif->write_glyphs (w, desired_glyph, desired_row->used[TEXT_AREA] - i);
rif->write_glyphs (w, updated_row, desired_glyph,
TEXT_AREA, desired_row->used[TEXT_AREA] - i);
changed_p = 1;
}
@ -3739,7 +3728,7 @@ update_text_area (struct window *w, int vpos)
if (i >= desired_row->used[TEXT_AREA])
rif->cursor_to (w, vpos, i, desired_row->y,
desired_row->pixel_width);
rif->clear_end_of_line (w, -1);
rif->clear_end_of_line (w, updated_row, TEXT_AREA, -1);
changed_p = 1;
}
else if (desired_row->pixel_width < current_row->pixel_width)
@ -3767,7 +3756,7 @@ update_text_area (struct window *w, int vpos)
}
else
xlim = current_row->pixel_width;
rif->clear_end_of_line (w, xlim);
rif->clear_end_of_line (w, updated_row, TEXT_AREA, xlim);
changed_p = 1;
}
}
@ -3786,10 +3775,6 @@ update_window_line (struct window *w, int vpos, bool *mouse_face_overwritten_p)
struct redisplay_interface *rif = FRAME_RIF (XFRAME (WINDOW_FRAME (w)));
bool changed_p = 0;
/* Set the row being updated. This is important to let xterm.c
know what line height values are in effect. */
updated_row = desired_row;
/* A row can be completely invisible in case a desired matrix was
built with a vscroll and then make_cursor_line_fully_visible shifts
the matrix. Make sure to make such rows current anyway, since
@ -3803,7 +3788,7 @@ update_window_line (struct window *w, int vpos, bool *mouse_face_overwritten_p)
if (!desired_row->full_width_p && w->left_margin_cols > 0)
{
changed_p = 1;
update_marginal_area (w, LEFT_MARGIN_AREA, vpos);
update_marginal_area (w, desired_row, LEFT_MARGIN_AREA, vpos);
/* Setting this flag will ensure the vertical border, if
any, between this window and the one on its left will be
redrawn. This is necessary because updating the left
@ -3812,7 +3797,7 @@ update_window_line (struct window *w, int vpos, bool *mouse_face_overwritten_p)
}
/* Update the display of the text area. */
if (update_text_area (w, vpos))
if (update_text_area (w, desired_row, vpos))
{
changed_p = 1;
if (current_row->mouse_face_p)
@ -3823,7 +3808,7 @@ update_window_line (struct window *w, int vpos, bool *mouse_face_overwritten_p)
if (!desired_row->full_width_p && w->right_margin_cols > 0)
{
changed_p = 1;
update_marginal_area (w, RIGHT_MARGIN_AREA, vpos);
update_marginal_area (w, desired_row, RIGHT_MARGIN_AREA, vpos);
}
/* Draw truncation marks etc. */
@ -3842,7 +3827,6 @@ update_window_line (struct window *w, int vpos, bool *mouse_face_overwritten_p)
/* Update current_row from desired_row. */
make_current (w->desired_matrix, w->current_matrix, vpos);
updated_row = NULL;
return changed_p;
}

118
src/fileio.c
View file

@ -504,6 +504,10 @@ get a current directory to run processes in. */)
return Ffile_name_directory (filename);
}
/* Maximum number of bytes that DST will be longer than SRC
in file_name_as_directory. This occurs when SRCLEN == 0. */
enum { file_name_as_directory_slop = 2 };
/* Convert from file name SRC of length SRCLEN to directory name in
DST. MULTIBYTE non-zero means the file name in SRC is a multibyte
string. On UNIX, just make sure there is a terminating /. Return
@ -521,14 +525,10 @@ file_name_as_directory (char *dst, const char *src, ptrdiff_t srclen,
return 2;
}
strcpy (dst, src);
memcpy (dst, src, srclen);
if (!IS_DIRECTORY_SEP (dst[srclen - 1]))
{
dst[srclen] = DIRECTORY_SEP;
dst[srclen + 1] = '\0';
srclen++;
}
dst[srclen++] = DIRECTORY_SEP;
dst[srclen] = 0;
#ifdef DOS_NT
dostounix_filename (dst, multibyte);
#endif
@ -547,7 +547,8 @@ For a Unix-syntax file name, just appends a slash. */)
{
char *buf;
ptrdiff_t length;
Lisp_Object handler;
Lisp_Object handler, val;
USE_SAFE_ALLOCA;
CHECK_STRING (file);
if (NILP (file))
@ -569,10 +570,12 @@ For a Unix-syntax file name, just appends a slash. */)
if (!NILP (Vw32_downcase_file_names))
file = Fdowncase (file);
#endif
buf = alloca (SBYTES (file) + 10);
buf = SAFE_ALLOCA (SBYTES (file) + file_name_as_directory_slop + 1);
length = file_name_as_directory (buf, SSDATA (file), SBYTES (file),
STRING_MULTIBYTE (file));
return make_specified_string (buf, -1, length, STRING_MULTIBYTE (file));
val = make_specified_string (buf, -1, length, STRING_MULTIBYTE (file));
SAFE_FREE ();
return val;
}
/* Convert from directory name SRC of length SRCLEN to file name in
@ -584,18 +587,17 @@ static ptrdiff_t
directory_file_name (char *dst, char *src, ptrdiff_t srclen, bool multibyte)
{
/* Process as Unix format: just remove any final slash.
But leave "/" unchanged; do not change it to "". */
strcpy (dst, src);
if (srclen > 1
&& IS_DIRECTORY_SEP (dst[srclen - 1])
But leave "/" and "//" unchanged. */
while (srclen > 1
#ifdef DOS_NT
&& !IS_ANY_SEP (dst[srclen - 2])
&& !IS_ANY_SEP (src[srclen - 2])
#endif
)
{
dst[srclen - 1] = 0;
srclen--;
}
&& IS_DIRECTORY_SEP (src[srclen - 1])
&& ! (srclen == 2 && IS_DIRECTORY_SEP (src[0])))
srclen--;
memcpy (dst, src, srclen);
dst[srclen] = 0;
#ifdef DOS_NT
dostounix_filename (dst, multibyte);
#endif
@ -613,7 +615,8 @@ In Unix-syntax, this function just removes the final slash. */)
{
char *buf;
ptrdiff_t length;
Lisp_Object handler;
Lisp_Object handler, val;
USE_SAFE_ALLOCA;
CHECK_STRING (directory);
@ -636,10 +639,12 @@ In Unix-syntax, this function just removes the final slash. */)
if (!NILP (Vw32_downcase_file_names))
directory = Fdowncase (directory);
#endif
buf = alloca (SBYTES (directory) + 20);
buf = SAFE_ALLOCA (SBYTES (directory) + 1);
length = directory_file_name (buf, SSDATA (directory), SBYTES (directory),
STRING_MULTIBYTE (directory));
return make_specified_string (buf, -1, length, STRING_MULTIBYTE (directory));
val = make_specified_string (buf, -1, length, STRING_MULTIBYTE (directory));
SAFE_FREE ();
return val;
}
static const char make_temp_name_tbl[64] =
@ -837,6 +842,7 @@ filesystem tree, not (expand-file-name ".." dirname). */)
Lisp_Object handler, result, handled_name;
bool multibyte;
Lisp_Object hdir;
USE_SAFE_ALLOCA;
CHECK_STRING (name);
@ -1011,11 +1017,11 @@ filesystem tree, not (expand-file-name ".." dirname). */)
|| (p[2] == '.' && (IS_DIRECTORY_SEP (p[3])
|| p[3] == 0))))
lose = 1;
/* We want to replace multiple `/' in a row with a single
slash. */
else if (p > nm
&& IS_DIRECTORY_SEP (p[0])
&& IS_DIRECTORY_SEP (p[1]))
/* Replace multiple slashes with a single one, except
leave leading "//" alone. */
else if (IS_DIRECTORY_SEP (p[0])
&& IS_DIRECTORY_SEP (p[1])
&& (p != nm || IS_DIRECTORY_SEP (p[2])))
lose = 1;
p++;
}
@ -1098,10 +1104,11 @@ filesystem tree, not (expand-file-name ".." dirname). */)
else /* ~user/filename */
{
char *o, *p;
for (p = nm; *p && (!IS_DIRECTORY_SEP (*p)); p++);
o = alloca (p - nm + 1);
for (p = nm; *p && !IS_DIRECTORY_SEP (*p); p++)
continue;
o = SAFE_ALLOCA (p - nm + 1);
memcpy (o, nm, p - nm);
o [p - nm] = 0;
o[p - nm] = 0;
block_input ();
pw = getpwnam (o + 1);
@ -1217,7 +1224,8 @@ filesystem tree, not (expand-file-name ".." dirname). */)
if (!IS_DIRECTORY_SEP (nm[0]))
{
ptrdiff_t newlen = strlen (newdir);
char *tmp = alloca (newlen + strlen (nm) + 2);
char *tmp = alloca (newlen + file_name_as_directory_slop
+ strlen (nm) + 1);
file_name_as_directory (tmp, newdir, newlen, multibyte);
strcat (tmp, nm);
nm = tmp;
@ -1271,31 +1279,18 @@ filesystem tree, not (expand-file-name ".." dirname). */)
if (newdir)
{
/* Get rid of any slash at the end of newdir, unless newdir is
just / or // (an incomplete UNC name). */
/* Ignore any slash at the end of newdir, unless newdir is
just "/" or "//". */
length = strlen (newdir);
tlen = length + 1;
if (length > 1 && IS_DIRECTORY_SEP (newdir[length - 1])
#ifdef WINDOWSNT
&& !(length == 2 && IS_DIRECTORY_SEP (newdir[0]))
#endif
)
{
char *temp = alloca (length);
memcpy (temp, newdir, length - 1);
temp[length - 1] = 0;
length--;
newdir = temp;
}
while (length > 1 && IS_DIRECTORY_SEP (newdir[length - 1])
&& ! (length == 2 && IS_DIRECTORY_SEP (newdir[0])))
length--;
}
else
{
length = 0;
tlen = 0;
}
length = 0;
/* Now concatenate the directory and name to new space in the stack frame. */
tlen += strlen (nm) + 1;
tlen = length + file_name_as_directory_slop + strlen (nm) + 1;
#ifdef DOS_NT
/* Reserve space for drive specifier and escape prefix, since either
or both may need to be inserted. (The Microsoft x86 compiler
@ -1303,7 +1298,7 @@ filesystem tree, not (expand-file-name ".." dirname). */)
target = alloca (tlen + 4);
target += 4;
#else /* not DOS_NT */
target = alloca (tlen);
target = SAFE_ALLOCA (tlen);
#endif /* not DOS_NT */
*target = 0;
@ -1320,7 +1315,10 @@ filesystem tree, not (expand-file-name ".." dirname). */)
if (!(drive && nm[0] && IS_DIRECTORY_SEP (newdir[0])
&& newdir[1] == '\0'))
#endif
strcpy (target, newdir);
{
memcpy (target, newdir, length);
target[length] = 0;
}
}
else
file_name_as_directory (target, newdir, length, multibyte);
@ -1380,8 +1378,9 @@ filesystem tree, not (expand-file-name ".." dirname). */)
++o;
p += 3;
}
else if (p > target && IS_DIRECTORY_SEP (p[1]))
/* Collapse multiple `/' in a row. */
else if (IS_DIRECTORY_SEP (p[1])
&& (p != target || IS_DIRECTORY_SEP (p[2])))
/* Collapse multiple "/", except leave leading "//" alone. */
p++;
else
{
@ -1429,11 +1428,12 @@ filesystem tree, not (expand-file-name ".." dirname). */)
{
handled_name = call3 (handler, Qexpand_file_name,
result, default_directory);
if (STRINGP (handled_name))
return handled_name;
error ("Invalid handler in `file-name-handler-alist'");
if (! STRINGP (handled_name))
error ("Invalid handler in `file-name-handler-alist'");
result = handled_name;
}
SAFE_FREE ();
return result;
}

10
src/frame.h
View file

@ -56,16 +56,6 @@ enum vertical_scroll_bar_type
vertical_scroll_bar_right
};
enum text_cursor_kinds
{
DEFAULT_CURSOR = -2,
NO_CURSOR = -1,
FILLED_BOX_CURSOR,
HOLLOW_BOX_CURSOR,
BAR_CURSOR,
HBAR_CURSOR
};
enum fullscreen_type
{
FULLSCREEN_NONE,

11
src/gtkutil.c
View file

@ -1341,6 +1341,7 @@ x_wm_set_size_hint (struct frame *f, long int flags, bool user_position)
int base_width, base_height;
int min_rows = 0, min_cols = 0;
int win_gravity = f->win_gravity;
Lisp_Object fs_state, frame;
/* Don't set size hints during initialization; that apparently leads
to a race condition. See the thread at
@ -1348,6 +1349,16 @@ x_wm_set_size_hint (struct frame *f, long int flags, bool user_position)
if (NILP (Vafter_init_time) || !FRAME_GTK_OUTER_WIDGET (f))
return;
XSETFRAME (frame, f);
fs_state = Fframe_parameter (frame, Qfullscreen);
if (EQ (fs_state, Qmaximized) || EQ (fs_state, Qfullboth))
{
/* Don't set hints when maximized or fullscreen. Apparently KWin and
Gtk3 don't get along and the frame shrinks (!).
*/
return;
}
if (flags)
{
memset (&size_hints, 0, sizeof (size_hints));

1
src/lisp.h
View file

@ -4177,7 +4177,6 @@ extern void init_sys_modes (struct tty_display_info *);
extern void reset_sys_modes (struct tty_display_info *);
extern void init_all_sys_modes (void);
extern void reset_all_sys_modes (void);
extern void flush_pending_output (int) ATTRIBUTE_CONST;
extern void child_setup_tty (int);
extern void setup_pty (int);
extern int set_window_size (int, int, int);

8
src/nsterm.m
View file

@ -742,8 +742,8 @@ Free a pool and temporary objects it refers to (callable from C)
static void
ns_update_window_end (struct window *w, int cursor_on_p,
int mouse_face_overwritten_p)
ns_update_window_end (struct window *w, bool cursor_on_p,
bool mouse_face_overwritten_p)
/* --------------------------------------------------------------------------
Finished a grouped sequence of drawing calls
external (RIF) call; for one window called before update_end
@ -2341,8 +2341,8 @@ Free a pool and temporary objects it refers to (callable from C)
static void
ns_draw_window_cursor (struct window *w, struct glyph_row *glyph_row,
int x, int y, int cursor_type, int cursor_width,
int on_p, int active_p)
int x, int y, enum text_cursor_kinds cursor_type,
int cursor_width, bool on_p, bool active_p)
/* --------------------------------------------------------------------------
External call (RIF): draw cursor.
Note that CURSOR_WIDTH is meaningful only for (h)bar cursors.

72
src/process.c
View file

@ -826,6 +826,15 @@ allocate_pty (char pty_name[PTY_NAME_SIZE])
if (fd >= 0)
{
#ifdef PTY_OPEN
/* Set FD's close-on-exec flag. This is needed even if
PT_OPEN calls posix_openpt with O_CLOEXEC, since POSIX
doesn't require support for that combination.
Multithreaded platforms where posix_openpt ignores
O_CLOEXEC (or where PTY_OPEN doesn't call posix_openpt)
have a race condition between the PTY_OPEN and here. */
fcntl (fd, F_SETFD, FD_CLOEXEC);
#endif
/* check to make certain that both sides are available
this avoids a nasty yet stupid bug in rlogins */
#ifdef PTY_TTY_NAME_SPRINTF
@ -1322,15 +1331,18 @@ DEFUN ("process-thread", Fprocess_thread, Sprocess_thread,
DEFUN ("set-process-window-size", Fset_process_window_size,
Sset_process_window_size, 3, 3, 0,
doc: /* Tell PROCESS that it has logical window size HEIGHT and WIDTH. */)
(register Lisp_Object process, Lisp_Object height, Lisp_Object width)
(Lisp_Object process, Lisp_Object height, Lisp_Object width)
{
CHECK_PROCESS (process);
CHECK_RANGED_INTEGER (height, 0, INT_MAX);
CHECK_RANGED_INTEGER (width, 0, INT_MAX);
/* All known platforms store window sizes as 'unsigned short'. */
CHECK_RANGED_INTEGER (height, 0, USHRT_MAX);
CHECK_RANGED_INTEGER (width, 0, USHRT_MAX);
if (XPROCESS (process)->infd < 0
|| set_window_size (XPROCESS (process)->infd,
XINT (height), XINT (width)) <= 0)
|| (set_window_size (XPROCESS (process)->infd,
XINT (height), XINT (width))
< 0))
return Qnil;
else
return Qt;
@ -1590,22 +1602,9 @@ usage: (start-process NAME BUFFER PROGRAM &rest PROGRAM-ARGS) */)
function. The argument list is protected by the caller, so all
we really have to worry about is buffer. */
{
struct gcpro gcpro1, gcpro2;
current_dir = BVAR (current_buffer, directory);
GCPRO2 (buffer, current_dir);
current_dir = Funhandled_file_name_directory (current_dir);
if (NILP (current_dir))
/* If the file name handler says that current_dir is unreachable, use
a sensible default. */
current_dir = build_string ("~/");
current_dir = expand_and_dir_to_file (current_dir, Qnil);
if (NILP (Ffile_accessible_directory_p (current_dir)))
report_file_error ("Setting current directory",
BVAR (current_buffer, directory));
struct gcpro gcpro1;
GCPRO1 (buffer);
current_dir = encode_current_directory ();
UNGCPRO;
}
@ -1852,7 +1851,6 @@ create_process (Lisp_Object process, char **new_argv, Lisp_Object current_dir)
bool pty_flag = 0;
char pty_name[PTY_NAME_SIZE];
Lisp_Object lisp_pty_name = Qnil;
Lisp_Object encoded_current_dir;
inchannel = outchannel = -1;
@ -1914,15 +1912,13 @@ create_process (Lisp_Object process, char **new_argv, Lisp_Object current_dir)
/* This may signal an error. */
setup_process_coding_systems (process);
encoded_current_dir = ENCODE_FILE (current_dir);
block_input ();
block_child_signal ();
#ifndef WINDOWSNT
/* vfork, and prevent local vars from being clobbered by the vfork. */
{
Lisp_Object volatile encoded_current_dir_volatile = encoded_current_dir;
Lisp_Object volatile current_dir_volatile = current_dir;
Lisp_Object volatile lisp_pty_name_volatile = lisp_pty_name;
char **volatile new_argv_volatile = new_argv;
int volatile forkin_volatile = forkin;
@ -1931,7 +1927,7 @@ create_process (Lisp_Object process, char **new_argv, Lisp_Object current_dir)
pid = vfork ();
encoded_current_dir = encoded_current_dir_volatile;
current_dir = current_dir_volatile;
lisp_pty_name = lisp_pty_name_volatile;
new_argv = new_argv_volatile;
forkin = forkin_volatile;
@ -2043,11 +2039,9 @@ create_process (Lisp_Object process, char **new_argv, Lisp_Object current_dir)
if (pty_flag)
child_setup_tty (xforkout);
#ifdef WINDOWSNT
pid = child_setup (xforkin, xforkout, xforkout,
new_argv, 1, encoded_current_dir);
pid = child_setup (xforkin, xforkout, xforkout, new_argv, 1, current_dir);
#else /* not WINDOWSNT */
child_setup (xforkin, xforkout, xforkout,
new_argv, 1, encoded_current_dir);
child_setup (xforkin, xforkout, xforkout, new_argv, 1, current_dir);
#endif /* not WINDOWSNT */
}
@ -4012,15 +4006,12 @@ deactivate_process (Lisp_Object proc)
}
#endif
inchannel = p->infd;
/* Beware SIGCHLD hereabouts. */
if (inchannel >= 0)
flush_pending_output (inchannel);
for (i = 0; i < PROCESS_OPEN_FDS; i++)
close_process_fd (&p->open_fd[i]);
inchannel = p->infd;
if (inchannel >= 0)
{
p->infd = -1;
@ -5928,10 +5919,9 @@ process_send_signal (Lisp_Object process, int signo, Lisp_Object current_group,
return;
}
switch (signo)
{
#ifdef SIGCONT
case SIGCONT:
if (signo == SIGCONT)
{
p->raw_status_new = 0;
pset_status (p, Qrun);
p->tick = ++process_tick;
@ -5940,14 +5930,8 @@ process_send_signal (Lisp_Object process, int signo, Lisp_Object current_group,
status_notify (NULL);
redisplay_preserve_echo_area (13);
}
break;
#endif /* ! defined (SIGCONT) */
case SIGINT:
case SIGQUIT:
case SIGKILL:
flush_pending_output (p->infd);
break;
}
#endif
/* If we don't have process groups, send the signal to the immediate
subprocess. That isn't really right, but it's better than any

1
src/process.h
View file

@ -221,6 +221,7 @@ enum
extern void block_child_signal (void);
extern void unblock_child_signal (void);
extern Lisp_Object encode_current_directory (void);
extern void record_kill_process (struct Lisp_Process *, Lisp_Object);
/* Defined in sysdep.c. */

113
src/sysdep.c
View file

@ -337,16 +337,6 @@ child_status_changed (pid_t child, int *status, int options)
return get_child_status (child, status, WNOHANG | options, 0);
}
/*
* flush any pending output
* (may flush input as well; it does not matter the way we use it)
*/
void
flush_pending_output (int channel)
{
/* FIXME: maybe this function should be removed */
}
/* Set up the terminal at the other end of a pseudo-terminal that
we will be controlling an inferior through.
@ -481,10 +471,20 @@ sys_subshell (void)
pid_t pid;
int status;
struct save_signal saved_handlers[5];
Lisp_Object dir;
unsigned char *volatile str_volatile = 0;
unsigned char *str;
int len;
char *str = SSDATA (encode_current_directory ());
#ifdef DOS_NT
pid = 0;
#else
{
char *volatile str_volatile = str;
pid = vfork ();
str = str_volatile;
}
#endif
if (pid < 0)
error ("Can't spawn subshell");
saved_handlers[0].code = SIGINT;
saved_handlers[1].code = SIGQUIT;
@ -496,31 +496,8 @@ sys_subshell (void)
saved_handlers[3].code = 0;
#endif
/* Mentioning current_buffer->buffer would mean including buffer.h,
which somehow wedges the hp compiler. So instead... */
dir = intern ("default-directory");
if (NILP (Fboundp (dir)))
goto xyzzy;
dir = Fsymbol_value (dir);
if (!STRINGP (dir))
goto xyzzy;
dir = expand_and_dir_to_file (Funhandled_file_name_directory (dir), Qnil);
str_volatile = str = alloca (SCHARS (dir) + 2);
len = SCHARS (dir);
memcpy (str, SDATA (dir), len);
if (str[len - 1] != '/') str[len++] = '/';
str[len] = 0;
xyzzy:
#ifdef DOS_NT
pid = 0;
save_signal_handlers (saved_handlers);
#else
pid = vfork ();
if (pid == -1)
error ("Can't spawn subshell");
#endif
if (pid == 0)
@ -538,11 +515,10 @@ sys_subshell (void)
sh = "sh";
/* Use our buffer's default directory for the subshell. */
str = str_volatile;
if (str && chdir ((char *) str) != 0)
if (chdir (str) != 0)
{
#ifndef DOS_NT
emacs_perror ((char *) str);
emacs_perror (str);
_exit (EXIT_CANCELED);
#endif
}
@ -556,8 +532,6 @@ sys_subshell (void)
if (epwd)
{
strcpy (old_pwd, epwd);
if (str[len - 1] == '/')
str[len - 1] = '\0';
setenv ("PWD", str, 1);
}
st = system (sh);
@ -1196,7 +1170,8 @@ get_tty_size (int fd, int *widthp, int *heightp)
}
/* Set the logical window size associated with descriptor FD
to HEIGHT and WIDTH. This is used mainly with ptys. */
to HEIGHT and WIDTH. This is used mainly with ptys.
Return a negative value on failure. */
int
set_window_size (int fd, int height, int width)
@ -1208,10 +1183,7 @@ set_window_size (int fd, int height, int width)
size.ws_row = height;
size.ws_col = width;
if (ioctl (fd, TIOCSWINSZ, &size) == -1)
return 0; /* error */
else
return 1;
return ioctl (fd, TIOCSWINSZ, &size);
#else
#ifdef TIOCSSIZE
@ -1221,10 +1193,7 @@ set_window_size (int fd, int height, int width)
size.ts_lines = height;
size.ts_cols = width;
if (ioctl (fd, TIOCGSIZE, &size) == -1)
return 0;
else
return 1;
return ioctl (fd, TIOCGSIZE, &size);
#else
return -1;
#endif /* not SunOS-style */
@ -2485,7 +2454,7 @@ serial_configure (struct Lisp_Process *p,
Lisp_Object childp2 = Qnil;
Lisp_Object tem = Qnil;
struct termios attr;
int err = -1;
int err;
char summary[4] = "???"; /* This usually becomes "8N1". */
childp2 = Fcopy_sequence (p->childp);
@ -2852,29 +2821,41 @@ procfs_ttyname (int rdev)
return build_string (name);
}
static unsigned long
static uintmax_t
procfs_get_total_memory (void)
{
FILE *fmem;
unsigned long retval = 2 * 1024 * 1024; /* default: 2GB */
uintmax_t retval = 2 * 1024 * 1024; /* default: 2 GiB */
int c;
block_input ();
fmem = emacs_fopen ("/proc/meminfo", "r");
if (fmem)
{
unsigned long entry_value;
char entry_name[20]; /* the longest I saw is 13+1 */
uintmax_t entry_value;
bool done;
do
switch (fscanf (fmem, "MemTotal: %"SCNuMAX, &entry_value))
{
case 1:
retval = entry_value;
done = 1;
break;
case 0:
while ((c = getc (fmem)) != EOF && c != '\n')
continue;
done = c == EOF;
break;
default:
done = 1;
break;
}
while (!done);
while (!feof (fmem) && !ferror (fmem))
{
if (fscanf (fmem, "%s %lu kB\n", entry_name, &entry_value) >= 2
&& strcmp (entry_name, "MemTotal:") == 0)
{
retval = entry_value;
break;
}
}
fclose (fmem);
}
unblock_input ();
@ -3275,7 +3256,7 @@ system_process_attributes (Lisp_Object pid)
{
int proc_id;
int pagesize = getpagesize ();
int npages;
unsigned long npages;
int fscale;
struct passwd *pw;
struct group *gr;

29
src/w32.c
View file

@ -2503,8 +2503,6 @@ gettimeofday (struct timeval *__restrict tv, struct timezone *__restrict tz)
int
fdutimens (int fd, char const *file, struct timespec const timespec[2])
{
struct _utimbuf ut;
if (!timespec)
{
errno = ENOSYS;
@ -2515,12 +2513,28 @@ fdutimens (int fd, char const *file, struct timespec const timespec[2])
errno = EBADF;
return -1;
}
ut.actime = timespec[0].tv_sec;
ut.modtime = timespec[1].tv_sec;
/* _futime's prototype defines 2nd arg as having the type 'struct
_utimbuf', while utime needs to accept 'struct utimbuf' for
compatibility with Posix. So we need to use 2 different (but
equivalent) types to avoid compiler warnings, sigh. */
if (fd >= 0)
return _futime (fd, &ut);
{
struct _utimbuf _ut;
_ut.actime = timespec[0].tv_sec;
_ut.modtime = timespec[1].tv_sec;
return _futime (fd, &_ut);
}
else
return _utime (file, &ut);
{
struct utimbuf ut;
ut.actime = timespec[0].tv_sec;
ut.modtime = timespec[1].tv_sec;
/* Call 'utime', which is implemented below, not the MS library
function, which fails on directories. */
return utime (file, &ut);
}
}
@ -4501,6 +4515,9 @@ fstat (int desc, struct stat * buf)
return 0;
}
/* A version of 'utime' which handles directories as well as
files. */
int
utime (const char *name, struct utimbuf *times)
{

9
src/w32term.c
View file

@ -210,7 +210,6 @@ static int volatile input_signal_count;
int w32_message_fd = -1;
#endif /* CYGWIN */
static void x_update_window_end (struct window *, int, int);
static void w32_handle_tool_bar_click (struct frame *,
struct input_event *);
static void w32_define_cursor (Window, Cursor);
@ -676,8 +675,8 @@ w32_draw_vertical_window_border (struct window *w, int x, int y0, int y1)
here. */
static void
x_update_window_end (struct window *w, int cursor_on_p,
int mouse_face_overwritten_p)
x_update_window_end (struct window *w, bool cursor_on_p,
bool mouse_face_overwritten_p)
{
Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (XFRAME (w->frame));
@ -5300,8 +5299,8 @@ w32_clear_frame_area (struct frame *f, int x, int y, int width, int height)
static void
w32_draw_window_cursor (struct window *w, struct glyph_row *glyph_row,
int x, int y, int cursor_type, int cursor_width,
int on_p, int active_p)
int x, int y, enum text_cursor_kinds cursor_type,
int cursor_width, bool on_p, bool active_p)
{
if (on_p)
{

2
src/window.c
View file

@ -5408,7 +5408,7 @@ struct save_window_data
Lisp_Object saved_windows;
/* All fields above are traced by the GC.
From `fame-cols' down, the fields are ignored by the GC. */
From `frame-cols' down, the fields are ignored by the GC. */
int frame_cols, frame_lines, frame_menu_bar_lines;
int frame_tool_bar_lines;

38
src/xdisp.c
View file

@ -3912,10 +3912,14 @@ handle_face_prop (struct it *it)
/* For strings from a `display' property, use the face at
IT's current buffer position as the base face to merge
with, so that overlay strings appear in the same face as
surrounding text, unless they specify their own
faces. */
surrounding text, unless they specify their own faces.
For strings from wrap-prefix and line-prefix properties,
use the default face, possibly remapped via
Vface_remapping_alist. */
base_face_id = it->string_from_prefix_prop_p
? DEFAULT_FACE_ID
? (!NILP (Vface_remapping_alist)
? lookup_basic_face (it->f, DEFAULT_FACE_ID)
: DEFAULT_FACE_ID)
: underlying_face_id (it);
}
@ -7046,7 +7050,9 @@ get_next_display_element (struct it *it)
}
}
}
else
/* next_element_from_display_vector sets this flag according to
faces of the display vector glyphs, see there. */
else if (it->method != GET_FROM_DISPLAY_VECTOR)
{
int face_id = face_after_it_pos (it);
it->end_of_box_run_p
@ -25763,12 +25769,12 @@ x_produce_glyphs (struct it *it)
/* EXPORT for RIF:
Output LEN glyphs starting at START at the nominal cursor position.
Advance the nominal cursor over the text. The global variable
updated_row is the glyph row being updated, and updated_area is the
area of that row being updated. */
Advance the nominal cursor over the text. UPDATED_ROW is the glyph row
being updated, and UPDATED_AREA is the area of that row being updated. */
void
x_write_glyphs (struct window *w, struct glyph *start, int len)
x_write_glyphs (struct window *w, struct glyph_row *updated_row,
struct glyph *start, enum glyph_row_area updated_area, int len)
{
int x, hpos, chpos = w->phys_cursor.hpos;
@ -25811,7 +25817,8 @@ x_write_glyphs (struct window *w, struct glyph *start, int len)
Insert LEN glyphs from START at the nominal cursor position. */
void
x_insert_glyphs (struct window *w, struct glyph *start, int len)
x_insert_glyphs (struct window *w, struct glyph_row *updated_row,
struct glyph *start, enum glyph_row_area updated_area, int len)
{
struct frame *f;
int line_height, shift_by_width, shifted_region_width;
@ -25863,11 +25870,12 @@ x_insert_glyphs (struct window *w, struct glyph *start, int len)
(inclusive) to pixel column TO_X (exclusive). The idea is that
everything from TO_X onward is already erased.
TO_X is a pixel position relative to updated_area of currently
TO_X is a pixel position relative to UPDATED_AREA of currently
updated window W. TO_X == -1 means clear to the end of this area. */
void
x_clear_end_of_line (struct window *w, int to_x)
x_clear_end_of_line (struct window *w, struct glyph_row *updated_row,
enum glyph_row_area updated_area, int to_x)
{
struct frame *f;
int max_x, min_y, max_y;
@ -26463,7 +26471,7 @@ erase_phys_cursor (struct window *w)
where to put the cursor is specified by HPOS, VPOS, X and Y. */
void
display_and_set_cursor (struct window *w, int on,
display_and_set_cursor (struct window *w, bool on,
int hpos, int vpos, int x, int y)
{
struct frame *f = XFRAME (w->frame);
@ -26547,7 +26555,7 @@ display_and_set_cursor (struct window *w, int on,
of ON. */
static void
update_window_cursor (struct window *w, int on)
update_window_cursor (struct window *w, bool on)
{
/* Don't update cursor in windows whose frame is in the process
of being deleted. */
@ -26583,7 +26591,7 @@ update_window_cursor (struct window *w, int on)
in the window tree rooted at W. */
static void
update_cursor_in_window_tree (struct window *w, int on_p)
update_cursor_in_window_tree (struct window *w, bool on_p)
{
while (w)
{
@ -26602,7 +26610,7 @@ update_cursor_in_window_tree (struct window *w, int on_p)
Don't change the cursor's position. */
void
x_update_cursor (struct frame *f, int on_p)
x_update_cursor (struct frame *f, bool on_p)
{
update_cursor_in_window_tree (XWINDOW (f->root_window), on_p);
}

9
src/xterm.c
View file

@ -292,8 +292,6 @@ static void x_set_window_size_1 (struct frame *, int, int, int);
static void x_raise_frame (struct frame *);
static void x_lower_frame (struct frame *);
static const XColor *x_color_cells (Display *, int *);
static void x_update_window_end (struct window *, int, int);
static int x_io_error_quitter (Display *);
static struct terminal *x_create_terminal (struct x_display_info *);
void x_delete_terminal (struct terminal *);
@ -612,7 +610,8 @@ x_draw_vertical_window_border (struct window *w, int x, int y0, int y1)
here. */
static void
x_update_window_end (struct window *w, int cursor_on_p, int mouse_face_overwritten_p)
x_update_window_end (struct window *w, bool cursor_on_p,
bool mouse_face_overwritten_p)
{
Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (XFRAME (w->frame));
@ -7372,7 +7371,9 @@ x_clear_frame_area (struct frame *f, int x, int y, int width, int height)
/* RIF: Draw cursor on window W. */
static void
x_draw_window_cursor (struct window *w, struct glyph_row *glyph_row, int x, int y, int cursor_type, int cursor_width, int on_p, int active_p)
x_draw_window_cursor (struct window *w, struct glyph_row *glyph_row, int x,
int y, enum text_cursor_kinds cursor_type,
int cursor_width, bool on_p, bool active_p)
{
struct frame *f = XFRAME (WINDOW_FRAME (w));

6
test/ChangeLog
View file

@ -1,3 +1,9 @@
2013-08-21 David Engster <deng@randomsample.de>
* automated/eieio-tests.el, automated/eieio-test-persist.el:
* automated/eieio-test-methodinvoke.el: EIEIO tests from CEDET
upstream. Changed to use ERT.
2013-08-14 Daniel Hackney <dan@haxney.org>
* package-test.el: Remove tar-package-building functions. Tar file

379
test/automated/eieio-test-methodinvoke.el Normal file
View file

@ -0,0 +1,379 @@
;;; eieio-testsinvoke.el -- eieio tests for method invokation
;; Copyright (C) 2005, 2008, 2010, 2013 Free Software Foundation, Inc.
;; Author: Eric. M. Ludlam <zappo@gnu.org>
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;
;; Test method invocation order. From the common lisp reference
;; manual:
;;
;; QUOTE:
;; - All the :before methods are called, in most-specific-first
;; order. Their values are ignored. An error is signaled if
;; call-next-method is used in a :before method.
;;
;; - The most specific primary method is called. Inside the body of a
;; primary method, call-next-method may be used to call the next
;; most specific primary method. When that method returns, the
;; previous primary method can execute more code, perhaps based on
;; the returned value or values. The generic function no-next-method
;; is invoked if call-next-method is used and there are no more
;; applicable primary methods. The function next-method-p may be
;; used to determine whether a next method exists. If
;; call-next-method is not used, only the most specific primary
;; method is called.
;;
;; - All the :after methods are called, in most-specific-last order.
;; Their values are ignored. An error is signaled if
;; call-next-method is used in a :after method.
;;
;;
;; Also test behavior of `call-next-method'. From clos.org:
;;
;; QUOTE:
;; When call-next-method is called with no arguments, it passes the
;; current method's original arguments to the next method.
(require 'eieio)
(require 'ert)
(defvar eieio-test-method-order-list nil
"List of symbols stored during method invocation.")
(defun eieio-test-method-store ()
"Store current invocation class symbol in the invocation order list."
(let* ((keysym (aref [ :STATIC :BEFORE :PRIMARY :AFTER ]
(or eieio-generic-call-key 0)))
(c (list eieio-generic-call-methodname keysym (eieio--scoped-class))))
(setq eieio-test-method-order-list
(cons c eieio-test-method-order-list))))
(defun eieio-test-match (rightanswer)
"Do a test match."
(if (equal rightanswer eieio-test-method-order-list)
t
(error "eieio-test-methodinvoke.el: Test Failed!")))
(defvar eieio-test-call-next-method-arguments nil
"List of passed to methods during execution of `call-next-method'.")
(defun eieio-test-arguments-for (class)
"Returns arguments passed to method of CLASS during `call-next-method'."
(cdr (assoc class eieio-test-call-next-method-arguments)))
(defclass eitest-A () ())
(defclass eitest-AA (eitest-A) ())
(defclass eitest-AAA (eitest-AA) ())
(defclass eitest-B-base1 () ())
(defclass eitest-B-base2 () ())
(defclass eitest-B (eitest-B-base1 eitest-B-base2) ())
(defmethod eitest-F :BEFORE ((p eitest-B-base1))
(eieio-test-method-store))
(defmethod eitest-F :BEFORE ((p eitest-B-base2))
(eieio-test-method-store))
(defmethod eitest-F :BEFORE ((p eitest-B))
(eieio-test-method-store))
(defmethod eitest-F ((p eitest-B))
(eieio-test-method-store)
(call-next-method))
(defmethod eitest-F ((p eitest-B-base1))
(eieio-test-method-store)
(call-next-method))
(defmethod eitest-F ((p eitest-B-base2))
(eieio-test-method-store)
(when (next-method-p)
(call-next-method))
)
(defmethod eitest-F :AFTER ((p eitest-B-base1))
(eieio-test-method-store))
(defmethod eitest-F :AFTER ((p eitest-B-base2))
(eieio-test-method-store))
(defmethod eitest-F :AFTER ((p eitest-B))
(eieio-test-method-store))
(ert-deftest eieio-test-method-order-list-3 ()
(let ((eieio-test-method-order-list nil)
(ans '(
(eitest-F :BEFORE eitest-B)
(eitest-F :BEFORE eitest-B-base1)
(eitest-F :BEFORE eitest-B-base2)
(eitest-F :PRIMARY eitest-B)
(eitest-F :PRIMARY eitest-B-base1)
(eitest-F :PRIMARY eitest-B-base2)
(eitest-F :AFTER eitest-B-base2)
(eitest-F :AFTER eitest-B-base1)
(eitest-F :AFTER eitest-B)
)))
(eitest-F (eitest-B nil))
(setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
(eieio-test-match ans)))
;;; Test static invokation
;;
(defmethod eitest-H :STATIC ((class eitest-A))
"No need to do work in here."
'moose)
(ert-deftest eieio-test-method-order-list-4 ()
;; Both of these situations should succeed.
(should (eitest-H eitest-A))
(should (eitest-H (eitest-A nil))))
;;; Return value from :PRIMARY
;;
(defmethod eitest-I :BEFORE ((a eitest-A))
(eieio-test-method-store)
":before")
(defmethod eitest-I :PRIMARY ((a eitest-A))
(eieio-test-method-store)
":primary")
(defmethod eitest-I :AFTER ((a eitest-A))
(eieio-test-method-store)
":after")
(ert-deftest eieio-test-method-order-list-5 ()
(let ((eieio-test-method-order-list nil)
(ans (eitest-I (eitest-A nil))))
(should (string= ans ":primary"))))
;;; Multiple inheritance and the 'constructor' method.
;;
;; Constructor is a static method, so this is really testing
;; static method invocation and multiple inheritance.
;;
(defclass C-base1 () ())
(defclass C-base2 () ())
(defclass C (C-base1 C-base2) ())
(defmethod constructor :STATIC ((p C-base1) &rest args)
(eieio-test-method-store)
(if (next-method-p) (call-next-method))
)
(defmethod constructor :STATIC ((p C-base2) &rest args)
(eieio-test-method-store)
(if (next-method-p) (call-next-method))
)
(defmethod constructor :STATIC ((p C) &rest args)
(eieio-test-method-store)
(call-next-method)
)
(ert-deftest eieio-test-method-order-list-6 ()
(let ((eieio-test-method-order-list nil)
(ans '(
(constructor :STATIC C)
(constructor :STATIC C-base1)
(constructor :STATIC C-base2)
)))
(C nil)
(setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
(eieio-test-match ans)))
;;; Diamond Test
;;
;; For a diamond shaped inheritance structure, (call-next-method) can break.
;; As such, there are two possible orders.
(defclass D-base0 () () :method-invocation-order :depth-first)
(defclass D-base1 (D-base0) () :method-invocation-order :depth-first)
(defclass D-base2 (D-base0) () :method-invocation-order :depth-first)
(defclass D (D-base1 D-base2) () :method-invocation-order :depth-first)
(defmethod eitest-F ((p D))
"D"
(eieio-test-method-store)
(call-next-method))
(defmethod eitest-F ((p D-base0))
"D-base0"
(eieio-test-method-store)
;; This should have no next
;; (when (next-method-p) (call-next-method))
)
(defmethod eitest-F ((p D-base1))
"D-base1"
(eieio-test-method-store)
(call-next-method))
(defmethod eitest-F ((p D-base2))
"D-base2"
(eieio-test-method-store)
(when (next-method-p)
(call-next-method))
)
(ert-deftest eieio-test-method-order-list-7 ()
(let ((eieio-test-method-order-list nil)
(ans '(
(eitest-F :PRIMARY D)
(eitest-F :PRIMARY D-base1)
;; (eitest-F :PRIMARY D-base2)
(eitest-F :PRIMARY D-base0)
)))
(eitest-F (D nil))
(setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
(eieio-test-match ans)))
;;; Other invocation order
(defclass E-base0 () () :method-invocation-order :breadth-first)
(defclass E-base1 (E-base0) () :method-invocation-order :breadth-first)
(defclass E-base2 (E-base0) () :method-invocation-order :breadth-first)
(defclass E (E-base1 E-base2) () :method-invocation-order :breadth-first)
(defmethod eitest-F ((p E))
(eieio-test-method-store)
(call-next-method))
(defmethod eitest-F ((p E-base0))
(eieio-test-method-store)
;; This should have no next
;; (when (next-method-p) (call-next-method))
)
(defmethod eitest-F ((p E-base1))
(eieio-test-method-store)
(call-next-method))
(defmethod eitest-F ((p E-base2))
(eieio-test-method-store)
(when (next-method-p)
(call-next-method))
)
(ert-deftest eieio-test-method-order-list-8 ()
(let ((eieio-test-method-order-list nil)
(ans '(
(eitest-F :PRIMARY E)
(eitest-F :PRIMARY E-base1)
(eitest-F :PRIMARY E-base2)
(eitest-F :PRIMARY E-base0)
)))
(eitest-F (E nil))
(setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
(eieio-test-match ans)))
;;; Jan's methodinvoke order w/ multiple inheritance and :after methods.
;;
(defclass eitest-Ja ()
())
(defmethod initialize-instance :after ((this eitest-Ja) &rest slots)
;(message "+Ja")
(when (next-method-p)
(call-next-method))
;(message "-Ja")
)
(defclass eitest-Jb ()
())
(defmethod initialize-instance :after ((this eitest-Jb) &rest slots)
;(message "+Jb")
(when (next-method-p)
(call-next-method))
;(message "-Jb")
)
(defclass eitest-Jc (eitest-Jb)
())
(defclass eitest-Jd (eitest-Jc eitest-Ja)
())
(defmethod initialize-instance ((this eitest-Jd) &rest slots)
;(message "+Jd")
(when (next-method-p)
(call-next-method))
;(message "-Jd")
)
(ert-deftest eieio-test-method-order-list-9 ()
(should (eitest-Jd "test")))
;;; call-next-method with replacement arguments across a simple class hierarchy.
;;
(defclass CNM-0 ()
())
(defclass CNM-1-1 (CNM-0)
())
(defclass CNM-1-2 (CNM-0)
())
(defclass CNM-2 (CNM-1-1 CNM-1-2)
())
(defmethod CNM-M ((this CNM-0) args)
(push (cons 'CNM-0 (copy-sequence args))
eieio-test-call-next-method-arguments)
(when (next-method-p)
(call-next-method
this (cons 'CNM-0 args))))
(defmethod CNM-M ((this CNM-1-1) args)
(push (cons 'CNM-1-1 (copy-sequence args))
eieio-test-call-next-method-arguments)
(when (next-method-p)
(call-next-method
this (cons 'CNM-1-1 args))))
(defmethod CNM-M ((this CNM-1-2) args)
(push (cons 'CNM-1-2 (copy-sequence args))
eieio-test-call-next-method-arguments)
(when (next-method-p)
(call-next-method)))
(defmethod CNM-M ((this CNM-2) args)
(push (cons 'CNM-2 (copy-sequence args))
eieio-test-call-next-method-arguments)
(when (next-method-p)
(call-next-method
this (cons 'CNM-2 args))))
(ert-deftest eieio-test-method-order-list-10 ()
(let ((eieio-test-call-next-method-arguments nil))
(CNM-M (CNM-2 "") '(INIT))
(should (equal (eieio-test-arguments-for 'CNM-0)
'(CNM-1-1 CNM-2 INIT)))
(should (equal (eieio-test-arguments-for 'CNM-1-1)
'(CNM-2 INIT)))
(should (equal (eieio-test-arguments-for 'CNM-1-2)
'(CNM-1-1 CNM-2 INIT)))
(should (equal (eieio-test-arguments-for 'CNM-2)
'(INIT)))))

213
test/automated/eieio-test-persist.el Normal file
View file

@ -0,0 +1,213 @@
;;; eieio-persist.el --- Tests for eieio-persistent class
;; Copyright (C) 2011-2013 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;
;; The eieio-persistent base-class provides a vital service, that
;; could be used to accidentally load in malicious code. As such,
;; something as simple as calling eval on the generated code can't be
;; used. These tests exercises various flavors of data that might be
;; in a persistent object, and tries to save/load them.
;;; Code:
(require 'eieio)
(require 'eieio-base)
(require 'ert)
(defun persist-test-save-and-compare (original)
"Compare the object ORIGINAL against the one read fromdisk."
(eieio-persistent-save original)
(let* ((file (oref original :file))
(class (eieio-object-class original))
(fromdisk (eieio-persistent-read file class))
(cv (class-v class))
(slot-names (eieio--class-public-a cv))
(slot-deflt (eieio--class-public-d cv))
)
(unless (object-of-class-p fromdisk class)
(error "Persistent class %S != original class %S"
(eieio-object-class fromdisk)
class))
(while slot-names
(let* ((oneslot (car slot-names))
(origvalue (eieio-oref original oneslot))
(fromdiskvalue (eieio-oref fromdisk oneslot))
(initarg-p (eieio-attribute-to-initarg class oneslot))
)
(if initarg-p
(unless (equal origvalue fromdiskvalue)
(error "Slot %S Original Val %S != Persistent Val %S"
oneslot origvalue fromdiskvalue))
;; Else !initarg-p
(unless (equal (car slot-deflt) fromdiskvalue)
(error "Slot %S Persistent Val %S != Default Value %S"
oneslot fromdiskvalue (car slot-deflt))))
(setq slot-names (cdr slot-names)
slot-deflt (cdr slot-deflt))
))))
;;; Simple Case
;;
;; Simplest case is a mix of slots with and without initargs.
(defclass persist-simple (eieio-persistent)
((slot1 :initarg :slot1
:type symbol
:initform moose)
(slot2 :initarg :slot2
:initform "foo")
(slot3 :initform 2))
"A Persistent object with two initializable slots, and one not.")
(ert-deftest eieio-test-persist-simple-1 ()
(let ((persist-simple-1
(persist-simple "simple 1" :slot1 'goose :slot2 "testing"
:file (concat default-directory "test-ps1.pt"))))
(should persist-simple-1)
;; When the slot w/out an initarg has not been changed
(persist-test-save-and-compare persist-simple-1)
;; When the slot w/out an initarg HAS been changed
(oset persist-simple-1 slot3 3)
(persist-test-save-and-compare persist-simple-1)
(delete-file (oref persist-simple-1 file))))
;;; Slot Writers
;;
;; Replica of the test in eieio-tests.el -
(defclass persist-:printer (eieio-persistent)
((slot1 :initarg :slot1
:initform 'moose
:printer PO-slot1-printer)
(slot2 :initarg :slot2
:initform "foo"))
"A Persistent object with two initializable slots.")
(defun PO-slot1-printer (slotvalue)
"Print the slot value SLOTVALUE to stdout.
Assume SLOTVALUE is a symbol of some sort."
(princ "'")
(princ (symbol-name slotvalue))
(princ " ;; RAN PRINTER")
nil)
(ert-deftest eieio-test-persist-printer ()
(let ((persist-:printer-1
(persist-:printer "persist" :slot1 'goose :slot2 "testing"
:file (concat default-directory "test-ps2.pt"))))
(should persist-:printer-1)
(persist-test-save-and-compare persist-:printer-1)
(let* ((find-file-hook nil)
(tbuff (find-file-noselect "test-ps2.pt"))
)
(condition-case nil
(unwind-protect
(with-current-buffer tbuff
(goto-char (point-min))
(re-search-forward "RAN PRINTER"))
(kill-buffer tbuff))
(error "persist-:printer-1's Slot1 printer function didn't work.")))
(delete-file (oref persist-:printer-1 file))))
;;; Slot with Object
;;
;; A slot that contains another object that isn't persistent
(defclass persist-not-persistent ()
((slot1 :initarg :slot1
:initform 1)
(slot2 :initform 2))
"Class for testing persistent saving of an object that isn't
persistent. This class is instead used as a slot value in a
persistent class.")
(defclass persistent-with-objs-slot (eieio-persistent)
((pnp :initarg :pnp
:type (or null persist-not-persistent)
:initform nil))
"Class for testing the saving of slots with objects in them.")
(ert-deftest eieio-test-non-persistent-as-slot ()
(let ((persist-wos
(persistent-with-objs-slot
"persist wos 1"
:pnp (persist-not-persistent "pnp 1" :slot1 3)
:file (concat default-directory "test-ps3.pt"))))
(persist-test-save-and-compare persist-wos)
(delete-file (oref persist-wos file))))
;;; Slot with Object child of :type
;;
;; A slot that contains another object that isn't persistent
(defclass persist-not-persistent-subclass (persist-not-persistent)
((slot3 :initarg :slot1
:initform 1)
(slot4 :initform 2))
"Class for testing persistent saving of an object subclass that isn't
persistent. This class is instead used as a slot value in a
persistent class.")
(defclass persistent-with-objs-slot-subs (eieio-persistent)
((pnp :initarg :pnp
:type (or null persist-not-persistent-child)
:initform nil))
"Class for testing the saving of slots with objects in them.")
(ert-deftest eieio-test-non-persistent-as-slot-child ()
(let ((persist-woss
(persistent-with-objs-slot-subs
"persist woss 1"
:pnp (persist-not-persistent-subclass "pnps 1" :slot1 3)
:file (concat default-directory "test-ps4.pt"))))
(persist-test-save-and-compare persist-woss)
(delete-file (oref persist-woss file))))
;;; Slot with a list of Objects
;;
;; A slot that contains another object that isn't persistent
(defclass persistent-with-objs-list-slot (eieio-persistent)
((pnp :initarg :pnp
:type persist-not-persistent-list
:initform nil))
"Class for testing the saving of slots with objects in them.")
(ert-deftest eieio-test-slot-with-list-of-objects ()
(let ((persist-wols
(persistent-with-objs-list-slot
"persist wols 1"
:pnp (list (persist-not-persistent "pnp 1" :slot1 3)
(persist-not-persistent "pnp 2" :slot1 4)
(persist-not-persistent "pnp 3" :slot1 5))
:file (concat default-directory "test-ps5.pt"))))
(persist-test-save-and-compare persist-wols)
(delete-file (oref persist-wols file))))
;;; eieio-test-persist.el ends here

893
test/automated/eieio-tests.el Normal file
View file

@ -0,0 +1,893 @@
;;; eieio-tests.el -- eieio tests routines
;; Copyright (C) 1999-2003, 2005-2010, 2012-2013 Free Software
;; Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;
;; Test the various features of EIEIO.
(require 'ert)
(require 'eieio)
(require 'eieio-base)
(require 'eieio-opt)
(eval-when-compile (require 'cl))
;;; Code:
;; Set up some test classes
(defclass class-a ()
((water :initarg :water
:initform h20
:type symbol
:documentation "Detail about water.")
(classslot :initform penguin
:type symbol
:documentation "A class allocated slot."
:allocation :class)
(test-tag :initform nil
:documentation "Used to make sure methods are called.")
(self :initform nil
:type (or null class-a)
:documentation "Test self referencing types.")
)
"Class A")
(defclass class-b ()
((land :initform "Sc"
:type string
:documentation "Detail about land."))
"Class B")
(defclass class-ab (class-a class-b)
((amphibian :initform "frog"
:documentation "Detail about amphibian on land and water."))
"Class A and B combined.")
(defclass class-c ()
((slot-1 :initarg :moose
:initform moose
:type symbol
:allocation :instance
:documentation "Fisrt slot testing slot arguments."
:custom symbol
:label "Wild Animal"
:group borg
:protection :public)
(slot-2 :initarg :penguin
:initform "penguin"
:type string
:allocation :instance
:documentation "Second slot testing slot arguments."
:custom string
:label "Wild bird"
:group vorlon
:accessor get-slot-2
:protection :private)
(slot-3 :initarg :emu
:initform emu
:type symbol
:allocation :class
:documentation "Third slot test class allocated accessor"
:custom symbol
:label "Fuzz"
:group tokra
:accessor get-slot-3
:protection :private)
)
(:custom-groups (foo))
"A class for testing slot arguments."
)
(defclass class-subc (class-c)
((slot-1 ;; :initform moose - don't override this
)
(slot-2 :initform "linux" ;; Do override this one
:protection :private
))
"A class for testing slot arguments.")
;;; Defining a class with a slot tag error
;;
;; Temporarily disable this test because of macro expansion changes in
;; current Emacs trunk. It can be re-enabled when we have moved
;; `eieio-defclass' into the `defclass' macro and the
;; `eval-and-compile' there is removed.
;; (let ((eieio-error-unsupported-class-tags t))
;; (condition-case nil
;; (progn
;; (defclass class-error ()
;; ((error-slot :initarg :error-slot
;; :badslottag 1))
;; "A class with a bad slot tag.")
;; (error "No error was thrown for badslottag"))
;; (invalid-slot-type nil)))
;; (let ((eieio-error-unsupported-class-tags nil))
;; (condition-case nil
;; (progn
;; (defclass class-error ()
;; ((error-slot :initarg :error-slot
;; :badslottag 1))
;; "A class with a bad slot tag."))
;; (invalid-slot-type
;; (error "invalid-slot-type thrown when eieio-error-unsupported-class-tags is nil")
;; )))
(ert-deftest eieio-test-01-mix-alloc-initarg ()
;; Only run this test if the message framework thingy works.
(when (and (message "foo") (string= "foo" (current-message)))
;; Defining this class should generate a warning(!) message that
;; you should not mix :initarg with class allocated slots.
(defclass class-alloc-initarg ()
((throwwarning :initarg :throwwarning
:allocation :class))
"Throw a warning mixing allocation class and an initarg.")
;; Check that message is there
(should (current-message))
(should (string-match "Class allocated slots do not need :initarg"
(current-message)))))
(defclass abstract-class ()
((some-slot :initarg :some-slot
:initform nil
:documentation "A slot."))
:documentation "An abstract class."
:abstract t)
(ert-deftest eieio-test-02-abstract-class ()
;; Abstract classes cannot be instantiated, so this should throw an
;; error
(should-error (abstract-class "Test")))
(defgeneric generic1 () "First generic function")
(ert-deftest eieio-test-03-generics ()
(defun anormalfunction () "A plain function for error testing." nil)
(should-error
(progn
(defgeneric anormalfunction ()
"Attempt to turn it into a generic.")))
;; Check that generic-p works
(should (generic-p 'generic1))
(defmethod generic1 ((c class-a))
"Method on generic1."
'monkey)
(defmethod generic1 (not-an-object)
"Method generic1 that can take a non-object."
not-an-object)
(let ((ans-obj (generic1 (class-a "test")))
(ans-num (generic1 666)))
(should (eq ans-obj 'monkey))
(should (eq ans-num 666))))
(defclass static-method-class ()
((some-slot :initform nil
:allocation :class
:documentation "A slot."))
:documentation "A class used for testing static methods.")
(defmethod static-method-class-method :STATIC ((c static-method-class) value)
"Test static methods.
Argument C is the class bound to this static method."
(if (eieio-object-p c) (setq c (eieio-object-class c)))
(oset-default c some-slot value))
(ert-deftest eieio-test-04-static-method ()
;; Call static method on a class and see if it worked
(static-method-class-method static-method-class 'class)
(should (eq (oref static-method-class some-slot) 'class))
(static-method-class-method (static-method-class "test") 'object)
(should (eq (oref static-method-class some-slot) 'object)))
(ert-deftest eieio-test-05-static-method-2 ()
(defclass static-method-class-2 (static-method-class)
()
"A second class after the previous for static methods.")
(defmethod static-method-class-method :STATIC ((c static-method-class-2) value)
"Test static methods.
Argument C is the class bound to this static method."
(if (eieio-object-p c) (setq c (eieio-object-class c)))
(oset-default c some-slot (intern (concat "moose-" (symbol-name value)))))
(static-method-class-method static-method-class-2 'class)
(should (eq (oref static-method-class-2 some-slot) 'moose-class))
(static-method-class-method (static-method-class-2 "test") 'object)
(should (eq (oref static-method-class-2 some-slot) 'moose-object)))
;;; Perform method testing
;;
;;; Multiple Inheritance, and method signal testing
;;
(defvar eitest-ab nil)
(defvar eitest-a nil)
(defvar eitest-b nil)
(ert-deftest eieio-test-06-allocate-objects ()
;; allocate an object to use
(should (setq eitest-ab (class-ab "abby")))
(should (setq eitest-a (class-a "aye")))
(should (setq eitest-b (class-b "fooby"))))
(ert-deftest eieio-test-07-make-instance ()
(should (make-instance 'class-ab))
(should (make-instance 'class-a :water 'cho))
(should (make-instance 'class-b "a name")))
(defmethod class-cn ((a class-a))
"Try calling `call-next-method' when there isn't one.
Argument A is object of type symbol `class-a'."
(call-next-method))
(defmethod no-next-method ((a class-a) &rest args)
"Override signal throwing for variable `class-a'.
Argument A is the object of class variable `class-a'."
'moose)
(ert-deftest eieio-test-08-call-next-method ()
;; Play with call-next-method
(should (eq (class-cn eitest-ab) 'moose)))
(defmethod no-applicable-method ((b class-b) method &rest args)
"No need.
Argument B is for booger.
METHOD is the method that was attempting to be called."
'moose)
(ert-deftest eieio-test-09-no-applicable-method ()
;; Non-existing methods.
(should (eq (class-cn eitest-b) 'moose)))
(defmethod class-fun ((a class-a))
"Fun with class A."
'moose)
(defmethod class-fun ((b class-b))
"Fun with class B."
(error "Class B fun should not be called")
)
(defmethod class-fun-foo ((b class-b))
"Foo Fun with class B."
'moose)
(defmethod class-fun2 ((a class-a))
"More fun with class A."
'moose)
(defmethod class-fun2 ((b class-b))
"More fun with class B."
(error "Class B fun2 should not be called")
)
(defmethod class-fun2 ((ab class-ab))
"More fun with class AB."
(call-next-method))
;; How about if B is the only slot?
(defmethod class-fun3 ((b class-b))
"Even More fun with class B."
'moose)
(defmethod class-fun3 ((ab class-ab))
"Even More fun with class AB."
(call-next-method))
(ert-deftest eieio-test-10-multiple-inheritance ()
;; play with methods and mi
(should (eq (class-fun eitest-ab) 'moose))
(should (eq (class-fun-foo eitest-ab) 'moose))
;; Play with next-method and mi
(should (eq (class-fun2 eitest-ab) 'moose))
(should (eq (class-fun3 eitest-ab) 'moose)))
(ert-deftest eieio-test-11-self ()
;; Try the self referencing test
(should (oset eitest-a self eitest-a))
(should (oset eitest-ab self eitest-ab)))
(defvar class-fun-value-seq '())
(defmethod class-fun-value :BEFORE ((a class-a))
"Return `before', and push `before' in `class-fun-value-seq'."
(push 'before class-fun-value-seq)
'before)
(defmethod class-fun-value :PRIMARY ((a class-a))
"Return `primary', and push `primary' in `class-fun-value-seq'."
(push 'primary class-fun-value-seq)
'primary)
(defmethod class-fun-value :AFTER ((a class-a))
"Return `after', and push `after' in `class-fun-value-seq'."
(push 'after class-fun-value-seq)
'after)
(ert-deftest eieio-test-12-generic-function-call ()
;; Test value of a generic function call
;;
(let* ((class-fun-value-seq nil)
(value (class-fun-value eitest-a)))
;; Test if generic function call returns the primary method's value
(should (eq value 'primary))
;; Make sure :before and :after methods were run
(should (equal class-fun-value-seq '(after primary before)))))
;;; Test initialization methods
;;
(ert-deftest eieio-test-13-init-methods ()
(defmethod initialize-instance ((a class-a) &rest slots)
"Initialize the slots of class-a."
(call-next-method)
(if (/= (oref a test-tag) 1)
(error "shared-initialize test failed."))
(oset a test-tag 2))
(defmethod shared-initialize ((a class-a) &rest slots)
"Shared initialize method for class-a."
(call-next-method)
(oset a test-tag 1))
(let ((ca (class-a "class act")))
(should-not (/= (oref ca test-tag) 2))))
;;; Perform slot testing
;;
(ert-deftest eieio-test-14-slots ()
;; Check slot existence
(should (oref eitest-ab water))
(should (oref eitest-ab land))
(should (oref eitest-ab amphibian)))
(ert-deftest eieio-test-15-slot-missing ()
(defmethod slot-missing ((ab class-ab) &rest foo)
"If a slot in AB is unbound, return something cool. FOO."
'moose)
(should (eq (oref eitest-ab ooga-booga) 'moose))
(should-error (oref eitest-a ooga-booga) :type 'invalid-slot-name))
(ert-deftest eieio-test-16-slot-makeunbound ()
(slot-makeunbound eitest-a 'water)
;; Should now be unbound
(should-not (slot-boundp eitest-a 'water))
;; But should still exist
(should (slot-exists-p eitest-a 'water))
(should-not (slot-exists-p eitest-a 'moose))
;; oref of unbound slot must fail
(should-error (oref eitest-a water) :type 'unbound-slot))
(defvar eitest-vsca nil)
(defvar eitest-vscb nil)
(defclass virtual-slot-class ()
((base-value :initarg :base-value))
"Class has real slot :base-value and simulated slot :derived-value.")
(defmethod slot-missing ((vsc virtual-slot-class)
slot-name operation &optional new-value)
"Simulate virtual slot derived-value."
(cond
((or (eq slot-name :derived-value)
(eq slot-name 'derived-value))
(with-slots (base-value) vsc
(if (eq operation 'oref)
(+ base-value 1)
(setq base-value (- new-value 1)))))
(t (call-next-method))))
(ert-deftest eieio-test-17-virtual-slot ()
(setq eitest-vsca (virtual-slot-class "eitest-vsca" :base-value 1))
;; Check slot values
(should (= (oref eitest-vsca :base-value) 1))
(should (= (oref eitest-vsca :derived-value) 2))
(oset eitest-vsca :derived-value 3)
(should (= (oref eitest-vsca :base-value) 2))
(should (= (oref eitest-vsca :derived-value) 3))
(oset eitest-vsca :base-value 3)
(should (= (oref eitest-vsca :base-value) 3))
(should (= (oref eitest-vsca :derived-value) 4))
;; should also be possible to initialize instance using virtual slot
(setq eitest-vscb (virtual-slot-class "eitest-vscb" :derived-value 5))
(should (= (oref eitest-vscb :base-value) 4))
(should (= (oref eitest-vscb :derived-value) 5)))
(ert-deftest eieio-test-18-slot-unbound ()
(defmethod slot-unbound ((a class-a) &rest foo)
"If a slot in A is unbound, ignore FOO."
'moose)
(should (eq (oref eitest-a water) 'moose))
;; Check if oset of unbound works
(oset eitest-a water 'moose)
(should (eq (oref eitest-a water) 'moose))
;; oref/oref-default comparison
(should-not (eq (oref eitest-a water) (oref-default eitest-a water)))
;; oset-default -> oref/oref-default comparison
(oset-default (eieio-object-class eitest-a) water 'moose)
(should (eq (oref eitest-a water) (oref-default eitest-a water)))
;; After setting 'water to 'moose, make sure a new object has
;; the right stuff.
(oset-default (eieio-object-class eitest-a) water 'penguin)
(should (eq (oref (class-a "foo") water) 'penguin))
;; Revert the above
(defmethod slot-unbound ((a class-a) &rest foo)
"If a slot in A is unbound, ignore FOO."
;; Disable the old slot-unbound so we can run this test
;; more than once
(call-next-method)))
(ert-deftest eieio-test-19-slot-type-checking ()
;; Slot type checking
;; We should not be able to set a string here
(should-error (oset eitest-ab water "a string, not a symbol") :type 'invalid-slot-type)
(should-error (oset eitest-ab classslot "a string, not a symbol") :type 'invalid-slot-type)
(should-error (class-a "broken-type-a" :water "a string not a symbol") :type 'invalid-slot-type))
(ert-deftest eieio-test-20-class-allocated-slots ()
;; Test out class allocated slots
(defvar eitest-aa nil)
(setq eitest-aa (class-a "another"))
;; Make sure class slots do not track between objects
(let ((newval 'moose))
(oset eitest-aa classslot newval)
(should (eq (oref eitest-a classslot) newval))
(should (eq (oref eitest-aa classslot) newval)))
;; Slot should be bound
(should (slot-boundp eitest-a 'classslot))
(should (slot-boundp class-a 'classslot))
(slot-makeunbound eitest-a 'classslot)
(should-not (slot-boundp eitest-a 'classslot))
(should-not (slot-boundp class-a 'classslot)))
(defvar eieio-test-permuting-value nil)
(defvar eitest-pvinit nil)
(eval-and-compile
(setq eieio-test-permuting-value 1))
(defclass inittest nil
((staticval :initform 1)
(symval :initform eieio-test-permuting-value)
(evalval :initform (symbol-value 'eieio-test-permuting-value))
(evalnow :initform (symbol-value 'eieio-test-permuting-value)
:allocation :class)
)
"Test initforms that eval.")
(ert-deftest eieio-test-21-eval-at-construction-time ()
;; initforms that need to be evalled at construction time.
(setq eieio-test-permuting-value 2)
(setq eitest-pvinit (inittest "permuteme"))
(should (eq (oref eitest-pvinit staticval) 1))
(should (eq (oref eitest-pvinit symval) 'eieio-test-permuting-value))
(should (eq (oref eitest-pvinit evalval) 2))
(should (eq (oref eitest-pvinit evalnow) 1)))
(defvar eitest-tests nil)
(ert-deftest eieio-test-22-init-forms-dont-match-runnable ()
;; Init forms with types that don't match the runnable.
(defclass eitest-subordinate nil
((text :initform "" :type string))
"Test class that will be a calculated value.")
(defclass eitest-superior nil
((sub :initform (eitest-subordinate "test")
:type eitest-subordinate))
"A class with an initform that creates a class.")
(should (setq eitest-tests (eitest-superior "test")))
(should-error
(eval
'(defclass broken-init nil
((broken :initform 1
:type string))
"This class should break."))
:type 'invalid-slot-type))
(ert-deftest eieio-test-23-inheritance-check ()
(should (child-of-class-p class-ab class-a))
(should (child-of-class-p class-ab class-b))
(should (object-of-class-p eitest-a class-a))
(should (object-of-class-p eitest-ab class-a))
(should (object-of-class-p eitest-ab class-b))
(should (object-of-class-p eitest-ab class-ab))
(should (eq (eieio-class-parents class-a) nil))
(should (equal (eieio-class-parents class-ab) '(class-a class-b)))
(should (same-class-p eitest-a class-a))
(should (class-a-p eitest-a))
(should (not (class-a-p eitest-ab)))
(should (class-a-child-p eitest-a))
(should (class-a-child-p eitest-ab))
(should (not (class-a-p "foo")))
(should (not (class-a-child-p "foo"))))
(ert-deftest eieio-test-24-object-predicates ()
(let ((listooa (list (class-ab "ab") (class-a "a")))
(listoob (list (class-ab "ab") (class-b "b"))))
(should (class-a-list-p listooa))
(should (class-b-list-p listoob))
(should-not (class-b-list-p listooa))
(should-not (class-a-list-p listoob))))
(defvar eitest-t1 nil)
(ert-deftest eieio-test-25-slot-tests ()
(setq eitest-t1 (class-c "C1"))
;; Slot initialization
(should (eq (oref eitest-t1 slot-1) 'moose))
(should (eq (oref eitest-t1 :moose) 'moose))
;; Don't pass reference of private slot
(should-error (oref eitest-t1 slot-2) :type 'invalid-slot-name)
;; Check private slot accessor
(should (string= (get-slot-2 eitest-t1) "penguin"))
;; Pass string instead of symbol
(should-error (class-c "C2" :moose "not a symbol") :type 'invalid-slot-type)
(should (eq (get-slot-3 eitest-t1) 'emu))
(should (eq (get-slot-3 class-c) 'emu))
;; Check setf
(setf (get-slot-3 eitest-t1) 'setf-emu)
(should (eq (get-slot-3 eitest-t1) 'setf-emu))
;; Roll back
(setf (get-slot-3 eitest-t1) 'emu))
(defvar eitest-t2 nil)
(ert-deftest eieio-test-26-default-inheritance ()
;; See previous test, nor for subclass
(setq eitest-t2 (class-subc "subc"))
(should (eq (oref eitest-t2 slot-1) 'moose))
(should (eq (oref eitest-t2 :moose) 'moose))
(should (string= (get-slot-2 eitest-t2) "linux"))
(should-error (oref eitest-t2 slot-2) :type 'invalid-slot-name)
(should (string= (get-slot-2 eitest-t2) "linux"))
(should-error (class-subc "C2" :moose "not a symbol") :type 'invalid-slot-type))
;;(ert-deftest eieio-test-27-inherited-new-value ()
;;; HACK ALERT: The new value of a class slot is inherited by the
;; subclass! This is probably a bug. We should either share the slot
;; so sets on the baseclass change the subclass, or we should inherit
;; the original value.
;; (should (eq (get-slot-3 eitest-t2) 'emu))
;; (should (eq (get-slot-3 class-subc) 'emu))
;; (setf (get-slot-3 eitest-t2) 'setf-emu)
;; (should (eq (get-slot-3 eitest-t2) 'setf-emu)))
;; Slot protection
(defclass prot-0 ()
()
"Protection testing baseclass.")
(defmethod prot0-slot-2 ((s2 prot-0))
"Try to access slot-2 from this class which doesn't have it.
The object S2 passed in will be of class prot-1, which does have
the slot. This could be allowed, and currently is in EIEIO.
Needed by the eieio persistant base class."
(oref s2 slot-2))
(defclass prot-1 (prot-0)
((slot-1 :initarg :slot-1
:initform nil
:protection :public)
(slot-2 :initarg :slot-2
:initform nil
:protection :protected)
(slot-3 :initarg :slot-3
:initform nil
:protection :private))
"A class for testing the :protection option.")
(defclass prot-2 (prot-1)
nil
"A class for testing the :protection option.")
(defmethod prot1-slot-2 ((s2 prot-1))
"Try to access slot-2 in S2."
(oref s2 slot-2))
(defmethod prot1-slot-2 ((s2 prot-2))
"Try to access slot-2 in S2."
(oref s2 slot-2))
(defmethod prot1-slot-3-only ((s2 prot-1))
"Try to access slot-3 in S2.
Do not override for `prot-2'."
(oref s2 slot-3))
(defmethod prot1-slot-3 ((s2 prot-1))
"Try to access slot-3 in S2."
(oref s2 slot-3))
(defmethod prot1-slot-3 ((s2 prot-2))
"Try to access slot-3 in S2."
(oref s2 slot-3))
(defvar eitest-p1 nil)
(defvar eitest-p2 nil)
(ert-deftest eieio-test-28-slot-protection ()
(setq eitest-p1 (prot-1 ""))
(setq eitest-p2 (prot-2 ""))
;; Access public slots
(oref eitest-p1 slot-1)
(oref eitest-p2 slot-1)
;; Accessing protected slot out of context must fail
(should-error (oref eitest-p1 slot-2) :type 'invalid-slot-name)
;; Access protected slot in method
(prot1-slot-2 eitest-p1)
;; Protected slot in subclass method
(prot1-slot-2 eitest-p2)
;; Protected slot from parent class method
(prot0-slot-2 eitest-p1)
;; Accessing private slot out of context must fail
(should-error (oref eitest-p1 slot-3) :type 'invalid-slot-name)
;; Access private slot in ethod
(prot1-slot-3 eitest-p1)
;; Access private slot in subclass method must fail
(should-error (prot1-slot-3 eitest-p2) :type 'invalid-slot-name)
;; Access private slot by same class
(prot1-slot-3-only eitest-p1)
;; Access private slot by subclass in sameclass method
(prot1-slot-3-only eitest-p2))
;;; eieio-instance-inheritor
;; Test to make sure this works.
(defclass II (eieio-instance-inheritor)
((slot1 :initform 1)
(slot2)
(slot3))
"Instance Inheritor test class.")
(defvar eitest-II1 nil)
(defvar eitest-II2 nil)
(defvar eitest-II3 nil)
(ert-deftest eieio-test-29-instance-inheritor ()
(setq eitest-II1 (II "II Test."))
(oset eitest-II1 slot2 'cat)
(setq eitest-II2 (clone eitest-II1 "eitest-II2 Test."))
(oset eitest-II2 slot1 'moose)
(setq eitest-II3 (clone eitest-II2 "eitest-II3 Test."))
(oset eitest-II3 slot3 'penguin)
;; Test level 1 inheritance
(should (eq (oref eitest-II3 slot1) 'moose))
;; Test level 2 inheritance
(should (eq (oref eitest-II3 slot2) 'cat))
;; Test level 0 inheritance
(should (eq (oref eitest-II3 slot3) 'penguin)))
(defclass slotattr-base ()
((initform :initform init)
(type :type list)
(initarg :initarg :initarg)
(protection :protection :private)
(custom :custom (repeat string)
:label "Custom Strings"
:group moose)
(docstring :documentation
"Replace the doc-string for this property.")
(printer :printer printer1)
)
"Baseclass we will attempt to subclass.
Subclasses to override slot attributes.")
(defclass slotattr-ok (slotattr-base)
((initform :initform no-init)
(initarg :initarg :initblarg)
(custom :custom string
:label "One String"
:group cow)
(docstring :documentation
"A better doc string for this class.")
(printer :printer printer2)
)
"This class should allow overriding of various slot attributes.")
(ert-deftest eieio-test-30-slot-attribute-override ()
;; Subclass should not override :protection slot attribute
(should-error
(eval
'(defclass slotattr-fail (slotattr-base)
((protection :protection :public)
)
"This class should throw an error.")))
;; Subclass should not override :type slot attribute
(should-error
(eval
'(defclass slotattr-fail (slotattr-base)
((type :type string)
)
"This class should throw an error.")))
;; Initform should override instance allocation
(let ((obj (slotattr-ok "moose")))
(should (eq (oref obj initform) 'no-init))))
(defclass slotattr-class-base ()
((initform :allocation :class
:initform init)
(type :allocation :class
:type list)
(initarg :allocation :class
:initarg :initarg)
(protection :allocation :class
:protection :private)
(custom :allocation :class
:custom (repeat string)
:label "Custom Strings"
:group moose)
(docstring :allocation :class
:documentation
"Replace the doc-string for this property.")
)
"Baseclass we will attempt to subclass.
Subclasses to override slot attributes.")
(defclass slotattr-class-ok (slotattr-class-base)
((initform :initform no-init)
(initarg :initarg :initblarg)
(custom :custom string
:label "One String"
:group cow)
(docstring :documentation
"A better doc string for this class.")
)
"This class should allow overriding of various slot attributes.")
(ert-deftest eieio-test-31-slot-attribute-override-class-allocation ()
;; Same as test-30, but with class allocation
(should-error
(eval
'(defclass slotattr-fail (slotattr-class-base)
((protection :protection :public)
)
"This class should throw an error.")))
(should-error
(eval
'(defclass slotattr-fail (slotattr-class-base)
((type :type string)
)
"This class should throw an error.")))
(should (eq (oref-default slotattr-class-ok initform) 'no-init)))
(ert-deftest eieio-test-32-slot-attribute-override-2 ()
(let* ((cv (class-v 'slotattr-ok))
(docs (eieio--class-public-doc cv))
(names (eieio--class-public-a cv))
(cust (eieio--class-public-custom cv))
(label (eieio--class-public-custom-label cv))
(group (eieio--class-public-custom-group cv))
(types (eieio--class-public-type cv))
(args (eieio--class-initarg-tuples cv))
(i 0))
;; :initarg should override for subclass
(should (assoc :initblarg args))
(while (< i (length names))
(cond
((eq (nth i names) 'custom)
;; Custom slot attributes must override
(should (eq (nth i cust) 'string))
;; Custom label slot attribute must override
(should (string= (nth i label) "One String"))
(let ((grp (nth i group)))
;; Custom group slot attribute must combine
(should (and (memq 'moose grp) (memq 'cow grp)))))
(t nil))
(setq i (1+ i)))))
(defvar eitest-CLONETEST1 nil)
(defvar eitest-CLONETEST2 nil)
(ert-deftest eieio-test-32-test-clone-boring-objects ()
;; A simple make instance with EIEIO extension
(should (setq eitest-CLONETEST1 (make-instance 'class-a "a")))
(should (setq eitest-CLONETEST2 (clone eitest-CLONETEST1)))
;; CLOS form of make-instance
(should (setq eitest-CLONETEST1 (make-instance 'class-a)))
(should (setq eitest-CLONETEST2 (clone eitest-CLONETEST1))))
(defclass IT (eieio-instance-tracker)
((tracking-symbol :initform IT-list)
(slot1 :initform 'die))
"Instance Tracker test object.")
(ert-deftest eieio-test-33-instance-tracker ()
(let (IT-list IT1)
(should (setq IT1 (IT "trackme")))
;; The instance tracker must find this
(should (eieio-instance-tracker-find 'die 'slot1 'IT-list))
;; Test deletion
(delete-instance IT1)
(should-not (eieio-instance-tracker-find 'die 'slot1 'IT-list))))
(defclass SINGLE (eieio-singleton)
((a-slot :initarg :a-slot :initform t))
"A Singleton test object.")
(ert-deftest eieio-test-34-singletons ()
(let ((obj1 (SINGLE "Moose"))
(obj2 (SINGLE "Cow")))
(should (eieio-object-p obj1))
(should (eieio-object-p obj2))
(should (eq obj1 obj2))
(should (oref obj1 a-slot))))
(defclass NAMED (eieio-named)
((some-slot :initform nil)
)
"A class inheriting from eieio-named.")
(ert-deftest eieio-test-35-named-object ()
(let (N)
(should (setq N (NAMED "Foo")))
(should (string= "Foo" (oref N object-name)))
(should-error (oref N missing-slot) :type 'invalid-slot-name)
(oset N object-name "NewName")
(should (string= "NewName" (oref N object-name)))))
(defclass opt-test1 ()
()
"Abstract base class"
:abstract t)
(defclass opt-test2 (opt-test1)
()
"Instantiable child")
(ert-deftest eieio-test-36-build-class-alist ()
(should (= (length (eieio-build-class-alist opt-test1 nil)) 2))
(should (= (length (eieio-build-class-alist opt-test1 t)) 1)))
(ert-deftest eieio-test-37-persistent-classes ()
(load-file "eieio-test-persist.el"))
(provide 'eieio-tests)
;;; eieio-tests.el ends here

0
test/automated/package-test.el Executable file → Normal file
View file

0
test/automated/package-x-test.el Executable file → Normal file
View file