[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] xwidget_mvp 7ecc620 1/2: upstream merge
|
From: |
Joakim Verona |
|
Subject: |
[Emacs-diffs] xwidget_mvp 7ecc620 1/2: upstream merge |
|
Date: |
Fri, 13 Nov 2015 19:48:05 +0000 |
branch: xwidget_mvp
commit 7ecc62076c4094c8712d471100b8955e88619bec
Merge: 2f7b194 2765945
Author: Joakim Verona <address@hidden>
Commit: Joakim Verona <address@hidden>
upstream merge
---
ChangeLog.2 | 857 ++++++-
doc/lispref/files.texi | 50 +-
doc/lispref/os.texi | 66 +
doc/lispref/sequences.texi | 18 +
etc/NEWS | 60 +-
etc/images/icons/README | 9 +
etc/images/icons/hicolor/128x128/apps/emacs.png | Bin 21751 -> 13462 bytes
.../128x128/apps/{emacs.png => emacs23.png} | Bin 21751 -> 21751 bytes
etc/images/icons/hicolor/16x16/apps/emacs.png | Bin 1003 -> 954 bytes
.../hicolor/16x16/apps/{emacs.png => emacs23.png} | Bin 1003 -> 1003 bytes
etc/images/icons/hicolor/24x24/apps/emacs.png | Bin 1717 -> 1568 bytes
.../hicolor/24x24/apps/{emacs.png => emacs23.png} | Bin 1717 -> 1717 bytes
etc/images/icons/hicolor/32x32/apps/emacs.png | Bin 2542 -> 2236 bytes
.../hicolor/32x32/apps/{emacs.png => emacs23.png} | Bin 2542 -> 2542 bytes
etc/images/icons/hicolor/48x48/apps/emacs.png | Bin 5393 -> 3636 bytes
.../hicolor/48x48/apps/{emacs.png => emacs23.png} | Bin 5393 -> 5393 bytes
etc/images/icons/hicolor/scalable/apps/emacs.svg | 534 ++--
.../scalable/apps/{emacs.svg => emacs23.svg} | 0
.../hicolor/scalable/mimetypes/emacs-document.svg | 449 ++--
.../{emacs-document.svg => emacs-document23.svg} | 0
lisp/autorevert.el | 81 +-
lisp/cedet/cedet-global.el | 16 +-
lisp/cedet/ede/generic.el | 2 +-
lisp/character-fold.el | 74 +-
lisp/custom.el | 15 +-
lisp/dired-aux.el | 2 +
lisp/dired.el | 2 +-
lisp/emacs-lisp/ert.el | 5 +-
lisp/emacs-lisp/macroexp.el | 38 +-
lisp/emacs-lisp/map.el | 23 +-
lisp/emacs-lisp/package.el | 3 +-
lisp/emacs-lisp/seq.el | 360 ++--
lisp/emacs-lisp/thunk.el | 74 +
lisp/eshell/esh-mode.el | 5 +-
lisp/filenotify.el | 89 +-
lisp/files.el | 2 +-
lisp/gnus/auth-source.el | 2 +-
lisp/gnus/gnus-topic.el | 21 +-
lisp/help.el | 7 +-
lisp/international/ccl.el | 59 +-
lisp/isearch.el | 259 +-
lisp/json.el | 2 +-
lisp/net/eww.el | 11 +-
lisp/net/soap-client.el | 3185 ++++++++++++++------
lisp/net/soap-inspect.el | 421 ++-
lisp/net/tramp-compat.el | 10 +
lisp/net/tramp-smb.el | 6 +-
lisp/net/tramp.el | 1 +
lisp/obsolete/vc-arch.el | 4 +
lisp/progmodes/grep.el | 19 +-
lisp/progmodes/sh-script.el | 9 +-
lisp/simple.el | 27 +-
lisp/textmodes/tex-mode.el | 30 +-
lisp/vc/pcvs.el | 2 +-
lisp/vc/vc-bzr.el | 1 +
lisp/vc/vc-cvs.el | 2 +
lisp/vc/vc-git.el | 2 +
lisp/vc/vc-hg.el | 21 +-
lisp/vc/vc-mtn.el | 4 +
lisp/vc/vc-svn.el | 4 +
.../Cocoa/Emacs.base/Contents/Resources/Emacs.icns | Bin 237716 -> 145987
bytes
nt/addpm.c | 78 +-
nt/icons/emacs.ico | Bin 52028 -> 370070 bytes
src/dispnew.c | 4 +-
src/keyboard.c | 12 +-
src/lisp.h | 201 +-
src/lread.c | 6 +-
src/nsfns.m | 25 +-
src/nsimage.m | 16 +-
src/nsmenu.m | 50 +-
src/nsterm.h | 241 ++
src/nsterm.m | 961 +++++--
src/process.c | 6 +-
src/w32notify.c | 2 +-
src/window.c | 25 +-
src/xdisp.c | 24 +-
test/automated/auto-revert-tests.el | 4 +-
test/automated/file-notify-tests.el | 230 +-
test/automated/simple-test.el | 206 ++
test/automated/thunk-tests.el | 55 +
80 files changed, 6447 insertions(+), 2642 deletions(-)
diff --git a/ChangeLog.2 b/ChangeLog.2
index 8c30a11..d86ce38 100644
--- a/ChangeLog.2
+++ b/ChangeLog.2
@@ -1,3 +1,858 @@
+2015-10-25 Paul Eggert <address@hidden>
+
+ Revert commit that broke 'make bootstrap'
+
+ * lisp/custom.el (custom-declare-variable): Revert commit
+ 79fac080d277fed07b3c192890ad59d36d9f83b6. custom.el needs to work
+ even when pcase has not been defined yet, when doing bootstrapping.
+
+2015-10-25 Paul Eggert <address@hidden>
+
+ Port recent inline functions fix to Standard C
+
+ * src/lisp.h (LISP_MACRO_DEFUN, LISP_MACRO_DEFUN_VOID): Remove.
+ All uses rewritten to define the function directly rather than to
+ use a macro to define the function. This conforms to Standard C,
+ which does not allow stray semicolons at the top level. I hope it
+ also avoids the problems with TAGS. Those macros, though clever,
+ were pretty confusing anyway, and it wasn’t clear they were worth
+ the aggravation even without the TAGS problem.
+
+2015-10-24 Artur Malabarba <address@hidden>
+
+ * lisp/isearch.el: Make character-fold search the default again.
+
+2015-10-24 Artur Malabarba <address@hidden>
+
+ * lisp/character-fold.el: Many improvements.
+ (character-fold-search-forward, character-fold-search-backward):
+ New command.
+ (character-fold-to-regexp): Remove lax-whitespace hack.
+ (character-fold-search): Remove variable. Only isearch and
+ query-replace use char-folding, and they both have their own
+ variables to configure that.
+
+2015-10-24 Artur Malabarba <address@hidden>
+
+ * lisp/isearch.el: Generalize definition of regexp-function toggles.
+ (isearch-specify-regexp-function): New macro for specifying
+ possible values of `isearch-regexp-function'.
+ (isearch-toggle-character-fold, isearch-toggle-symbol)
+ (isearch-toggle-word): Define with `isearch-specify-regexp-function'.
+
+2015-10-24 Artur Malabarba <address@hidden>
+
+ * lisp/isearch.el (search-default-regexp-mode): New variable.
+ (isearch-mode): Use it.
+
+2015-10-24 Artur Malabarba <address@hidden>
+
+ * lisp/isearch.el (search-exit-option, search-slow-window-lines)
+ (search-slow-speed, search-upper-case)
+ (search-nonincremental-instead, search-whitespace-regexp)
+ (search-invisible, isearch-hide-immediately)
+ (isearch-resume-in-command-history, search-ring-max)
+ (regexp-search-ring-max, search-ring-update, search-highlight)
+ (isearch-fail): Delete :group entries.
+
+2015-10-24 Artur Malabarba <address@hidden>
+
+ * lisp/custom.el (custom-declare-variable): Shorten code a bit.
+
+2015-10-24 Juanma Barranquero <address@hidden>
+
+ addpm.c: Silence some warnings.
+
+ * nt/addpm.c (DdeCommand): Cast pData argument of DdeClientTransaction
+ to LPBYTE.
+ (add_registry): Pass NULL to optional lpClass argument of
+ RegCreateKeyEx, not an empty string.
+
+2015-10-24 Juanma Barranquero <address@hidden>
+
+ addpm.c: Do not add obsolete GTK libraries to the path.
+
+ * nt/addpm.c (REG_GTK, REG_RUNEMACS_PATH): Delete.
+ (add_registry): Remove variables `size' and `gtk_key'.
+ Do not add the GTK DLL directory to the library search path; it is
+ confusing behavior (in particular, the same Emacs version with and
+ without invoking addpm will use a different path), and the GTK image
+ libraries are obsolete anyway.
+
+2015-10-24 Juanma Barranquero <address@hidden>
+
+ addpm.c: Replace existing registry entries, but do not create new ones
+
+ * nt/addpm.c (add_registry): If the Emacs registry key exists, replace
+ existing values from previous versions, but do not add new ones; the
+ key could exist for other reasons unrelated to old Emacsen, like X-style
+ resources, or to set some environment variables like HOME or LANG, and
+ in that case we don't want to populate it with obsolete values.
+
+2015-10-24 Juanma Barranquero <address@hidden>
+
+ * nt/addpm.c (add_registry): Do not compute unused return value.
+
+2015-10-24 Juanma Barranquero <address@hidden>
+
+ addpm.c: Don't pass REG_OPTION_NON_VOLATILE to RegOpenKeyEx
+
+ * nt/addpm.c (add_registry): Pass 0 to ulOptions argument of
+ RegOpenKeyEx, not REG_OPTION_NON_VOLATILE. This doesn't change
+ current behavior because REG_OPTION_NON_VOLATILE is defined to
+ be 0L anyway, but that option is actually documented only for
+ RegCreateKeyEx.
+
+2015-10-24 Juanma Barranquero <address@hidden>
+
+ * src/w32notify.c (Fw32notify_add_watch): Fix version check.
+
+2015-10-24 Eli Zaretskii <address@hidden>
+
+ Update frame title when redisplay scrolls selected window
+
+ * src/xdisp.c (redisplay_window): Reconsider the frame's title
+ when the mode-line of the frame's selected window needs to be
+ updated.
+
+2015-10-24 Eli Zaretskii <address@hidden>
+
+ Update frame title when scrolling the selected window
+
+ * src/window.c (wset_update_mode_line): New function, sets either the
+ window's update_mode_line flag or the global update_mode_lines
+ variable.
+ (Fset_window_start, set_window_buffer, window_scroll_pixel_based)
+ (window_scroll_line_based): Call it instead of only setting the
+ window's update_mode_line flag.
+
+2015-10-24 Eli Zaretskii <address@hidden>
+
+ An even better fix for bug#21739
+
+ * src/window.c (set_window_buffer): If the window is the frame's
+ selected window, set update_mode_lines, not the window's
+ update_mode_line flag. (Bug#21739)
+ * src/buffer.c (Fkill_buffer): Undo last change.
+ (set_update_modelines_for_buf): Function deleted.
+
+2015-10-24 Thomas Fitzsimmons <address@hidden>
+
+ Sync with soap-client repository, version 3.0.0
+
+2015-10-24 Nicolas Petton <address@hidden>
+
+ Update the new icon
+
+ Move the E slightly to the right in the circle.
+
+ * etc/images/icons/hicolor/128x128/apps/emacs.png:
+ * etc/images/icons/hicolor/16x16/apps/emacs.png:
+ * etc/images/icons/hicolor/24x24/apps/emacs.png:
+ * etc/images/icons/hicolor/32x32/apps/emacs.png:
+ * etc/images/icons/hicolor/48x48/apps/emacs.png:
+ * etc/images/icons/hicolor/scalable/apps/emacs.svg:
+ * nextstep/Cocoa/Emacs.base/Contents/Resources/Emacs.icns:
+ * nt/icons/emacs.ico: New icom update.
+
+2015-10-24 Eli Zaretskii <address@hidden>
+
+ Avoid missing inline functions from lisp.h in TAGS
+
+ * src/lisp.h (LISP_MACRO_DEFUN): Mention in the commentary the
+ need to end each invocation with a semi-colon.
+ Add a semi-colon at the end of each invocation of LISP_MACRO_DEFUN
+ and LISP_MACRO_DEFUN_VOID. This is to avoid missing in TAGS
+ inline functions defined immediately after each invocation, and
+ also avoid tagging every invocation of these macros.
+
+2015-10-24 Eli Zaretskii <address@hidden>
+
+ A better fix for bug#21739
+
+ * src/buffer.c (set_update_modelines_for_buf): New function.
+ (Fkill_buffer): Use it to set the global variable
+ update_mode_lines if the killed buffer was displayed in some
+ window. Don't set windows_or_buffers_changed. This is a better
+ fix for bug#21739 than the previous fix, since it will cause only
+ redisplay of mode lines, not of entire windows, but will still
+ catch attention of x_consider_frame_title in xdisp.c, which
+ redraws the frame title.
+
+2015-10-24 Tassilo Horn <address@hidden>
+
+ * lisp/dired-aux.el (dired-compress-files-alist): Add support for
+ tar.bz2 and tar.xz archives.
+
+2015-10-23 Eli Zaretskii <address@hidden>
+
+ Fix infloop in redisplay introduced by a recent change
+
+ * src/xdisp.c (redisplay_internal): Avoid inflooping when
+ redisplaying the selected window sets the selected frame's
+ redisplay flag. (Bug#21745)
+
+2015-10-23 Nicolas Petton <address@hidden>
+
+ * lisp/emacs-lisp/thunk.el: Better documentation.
+
+2015-10-23 Nicolas Petton <address@hidden>
+
+ Replace the old icon for Windows and Mac OSX
+
+ * nt/icons/emacs.ico:
+ * nextstep/Cocoa/Emacs.base/Contents/Resources/Emacs.icns:
+ Use the new icons.
+
+2015-10-23 Stephen Leake <address@hidden>
+
+ * lisp/emacs-lisp/package.el (package-autoload-ensure-default-file):
+ `load-path' should contain only directory names.
+
+2015-10-23 Nicolas Petton <address@hidden>
+
+ New library thunk.el
+
+ thunk.el is extracted from stream.el in ELPA, with additional tests.
+
+ * lisp/emacs-lisp/thunk.el: New file.
+ * test/automated/thunk-tests.el: New file.
+ * etc/NEWS: Add information about thunk.el
+
+2015-10-23 Michael Albinus <address@hidden>
+
+ Fix Bug#21669
+
+ * lisp/filenotify.el (file-notify-rm-watch): Improve check for
+ calling low-level functions.
+
+ * test/automated/file-notify-tests.el (file-notify--test-timeout):
+ Decrase to 6 seconds for remote directories.
+ (file-notify-test02-events): Expect different number of
+ `attribute-changed' events for the local and remote cases. Apply
+ short delays between the operations, in order to receive all
+ events in the remote case. Combine `attribute-change' tests.
+ (Bug#21669)
+
+2015-10-23 Eli Zaretskii <address@hidden>
+
+ Decode the HTML source when displaying it in EWW
+
+ * lisp/net/eww.el (eww-view-source): Decode the HTML source
+ according to its headers.
+
+2015-10-23 Nicolas Petton <address@hidden>
+
+ New default icon
+
+ * etc/images/icons/hicolor/128x128/apps/emacs23.png:
+ * etc/images/icons/hicolor/16x16/apps/emacs23.png:
+ * etc/images/icons/hicolor/24x24/apps/emacs23.png:
+ * etc/images/icons/hicolor/32x32/apps/emacs23.png:
+ * etc/images/icons/hicolor/48x48/apps/emacs23.png:
+ * etc/images/icons/hicolor/scalable/apps/emacs23.svg:
+ * etc/images/icons/hicolor/scalable/mimetypes/emacs-document23.svg:
+ Move the old logo files to emacs23.*.
+ * etc/images/icons/hicolor/128x128/apps/emacs.png:
+ * etc/images/icons/hicolor/16x16/apps/emacs.png:
+ * etc/images/icons/hicolor/24x24/apps/emacs.png:
+ * etc/images/icons/hicolor/32x32/apps/emacs.png:
+ * etc/images/icons/hicolor/48x48/apps/emacs.png:
+ * etc/images/icons/hicolor/scalable/apps/emacs.svg:
+ * etc/images/icons/hicolor/scalable/mimetypes/emacs-document.svg:
+ New files.
+ * etc/images/icons/README: Update the copyright information.
+
+2015-10-23 Eli Zaretskii <address@hidden>
+
+ Fix redisplay of frame title when current buffer is killed
+
+ * src/buffer.c (Fkill_buffer): Set windows_or_buffers_changed to a
+ non-zero value, to redisplay more than just the affected windows.
+ (Bug#21739)
+
+2015-10-23 Anders Lindgren <address@hidden>
+
+ NextSten maximization and NSTRACE rewrite
+
+ Full-height, full-width, and maximized windows now cover the
+ entire screen (except the menu bar), including the part where the
+ system dock is placed. The system zoom animation is no longer
+ used.
+
+ Made NonMaximized->FullWidth->FullHeight->NonMaximized restore the
+ original size.
+
+ * src/nsterm.m (ns_menu_bar_height): New function, return height of
+ the menu bar, or 0 when it's hidden.
+ (constrain_frame_rect): New function for constraining a frame.
+ (ns_constrain_all_frames): Set frame size explicitly rather than
+ relying on the system doing it for us by writing back the current
+ frame size.
+ (windowWillUseStandardFrame): Register non-maximized width or
+ height as new user size. When entering full width or height,
+ the other size component is taken from the user size.
+ (fullscreenState): New method for accessing the fullscreen state.
+ (constrainFrameRect): Restrict frame to be placed under the menu bar,
+ if present. The old version, sometimes, restricted the height of a
+ frame to the screen, this version never does this.
+ (zoom): Perform zoom by setting the frame to the full size of the
+ screen (minus the menu bar). The default system function, with the
+ zoom animation, is no longer used, as the final frame size doesn't
+ cover the entire screen.
+
+ Rework how to constrain resizing to the character grid. The old
+ system used "resizeIncrements" in NSWindows. However, once a frame
+ was resized so that it was not aligned to the text grid, it
+ remained unaligned even after a resize. In addition, it conflicted
+ when resizing a fullheight window.
+
+ * src/nsterm.m (windowWillResize): Restrict frame size to text grid,
+ unless when pixelwise frame resizing is enabled.
+ (updateFrameSize, initFrameFromEmacs)
+ (toggleFullScreen, handleFS): Don't set resizeIncrements.
+
+ Redesign the NS trace system. The call structure is represented
+ using indentations and vertical lines. The NSTRACE macro accepts
+ printf-style arguments. New macros for printing various
+ information.
+
+ * src/nsterm.h (NSTRACE_ENABLED): Macro to enable trace system.
+ (NSTRACE, NSTRACE_WHEN, NSTRACE_UNLESS): Macros to start a new
+ block (typically a function), accept printf-style arguments.
+ (NSTRACE_MSG): Macro for extra information, accepts
+ printf-style arguments.
+ (NSTRACE_what): Macros for printing various types.
+ (NSTRACE_FMT_what): Macro with printf format string snippets.
+ (NSTRACE_ARG_what): Macros for passing printf-style arguments,
+ corresponds to NSTRACE_FMT_what.
+ (NSTRACE_RETURN): Macro to print return value, accept
+ printf-style arguments.
+ (NSTRACE_RETURN_what): Macros to print return value for
+ various types.
+
+ * nsterm.m: Remove old NSTRACE macro
+ * src/nsterm.m (nstrace_num): Trace counter.
+ (nstrace_depth): Current call depth.
+ (nstrace_leave): NSTRACE support function, called when the
+ local variable "nstrace_enabled" goes out of scope using the
+ "cleanup" extension.
+ (ns_print_fullscreen_type_name): NSTRACE_FSTYPE support function.
+ (constrain_frame_rect, ns_constrain_all_frames)
+ (ns_update_auto_hide_menu_bar, ns_update_begin)
+ (ns_update_window_begin, update_window_end, ns_update_end)
+ (ns_focus, ns_unfocus, ns_ring_bell, ns_frame_raise_lower)
+ (ns_frame_rehighlight, x_make_frame_visible)
+ (x_make_frame_invisible, x_iconify_frame, x_free_frame_resources)
+ (x_destroy_window, x_set_offset, x_set_window_size)
+ (ns_fullscreen_hook, ns_lisp_to_color, ns_color_to_lisp)
+ (ns_defined_color, frame_set_mouse_pixel_position)
+ (note_mouse_movement, ns_mouse_position, ns_frame_up_to_date)
+ (ns_define_frame_cursor, x_get_keysym_name, ns_redraw_scroll_bars)
+ (ns_clear_frame, ns_clear_frame_area, ns_scroll_run)
+ (ns_after_update_window_line, ns_shift_glyphs_for_insert)
+ (dumpcursor, ns_draw_vertical_window_border)
+ (ns_draw_window_divider, ns_draw_relief)
+ (ns_dumpglyphs_box_or_relief, ns_maybe_dumpglyphs_background)
+ (ns_dumpglyphs_image, ns_draw_glyph_string, ns_send_appdefined)
+ (ns_read_socket, ns_select, ns_set_vertical_scroll_bar)
+ (ns_set_horizontal_scroll_bar, ns_condemn_scroll_bars)
+ (ns_redeem_scroll_bar, ns_judge_scroll_bars, ns_delete_terminal)
+ (ns_create_terminal, ns_term_init, sendEvent)
+ (applicationDidFinishLaunching, applicationDidBecomeActive)
+ (timeout_handler, fd_handler, EmacsView_dealloc, changeFont)
+ (acceptsFirstResponder, resetCursorRects, keyDown, mouseDown)
+ (deltaIsZero, rightMouseDown, otherMouseDown, mouseUp)
+ (rightMouseUp, otherMouseUp, scrollWheel, mouseMoved)
+ (mouse_autoselect_window, in_window, mouseDragged)
+ (rightMouseDragged, otherMouseDragged, windowShouldClose)
+ (updateFrameSize, windowWillResize, windowDidResize)
+ (windowDidBecomeKey, windowDidResignKey, windowWillMiniaturize)
+ (initFrameFromEmacs, windowDidMove, windowDidDeminiaturize)
+ (windowDidExpose, windowDidMiniaturize, windowWillEnterFullScreen)
+ (windowDidEnterFullScreen, windowWillExitFullScreen)
+ (windowDidExitFullScreen, toggleFullScreen, handleFS, setFSValue)
+ (mouseEntered, mouseExited, menuDown, toolbarClicked, drawRect)
+ (draggingEntered, performDragOperation, validRequestorForSendType)
+ (setMiniwindowImage, constrainFrameRect, performZoom, zoom)
+ (EmacsScroller_initFrame, EmacsScroller_setFrame)
+ (EmacsScroller_dealloc, condemn, reprieve, judge)
+ (resetCursorRects, setPosition, EmacsScroller_mouseDown)
+ (EmacsScroller_mouseDragged, syms_of_nsterm): Use new trace system.
+
+ * nsfns.m: Remove old NSTRACE macro
+ * src/nsfns.m (x_set_icon_name, ns_set_name, x_explicitly_set_name)
+ (x_implicitly_set_name, x_set_title, ns_set_name_as_filename)
+ (ns_implicitly_set_icon_type, x_set_icon_type): Use new trace system.
+
+ * nsimage.m: Remove old NSTRACE macro
+ * src/nsimage.m (ns_image_from_XBM, ns_image_for_XPM)
+ (ns_image_from_bitmap_file, ns_load_image): Use new trace system.
+
+ * nsmenu.m: Remove old NSTRACE macro
+ * src/nsmenu.m (ns_update_menubar, ns_menu_show, ns_popup_dialog):
+ Use new trace system.
+
+2015-10-22 Katsumi Yamaoka <address@hidden>
+
+ No need to use eval-and-compile
+
+ * lisp/gnus/auth-source.el: Do require epg (when compiling) before
+ autoload epg functions.
+
+2015-10-22 Katsumi Yamaoka <address@hidden>
+
+ Fix auth-source-epa-make-gpg-token compilation (bug#21724)
+
+ * lisp/gnus/auth-source.el: Add eval-and-compile to autoloads for
+ epg-context-set-passphrase-callback, epg-decrypt-string, and
+ epg-encrypt-string; require epg when compiling for the setf-method
+ for epg-context-armor. (bug#21724)
+
+2015-10-22 Eli Zaretskii <address@hidden>
+
+ Include file cleanup for w32 files in src directory
+
+ * src/w32xfns.c: Don't include keyboard.h, window.h, charset.h,
+ fontset.h, blockinput.h.
+ * src/w32uniscribe.c: Don't include dispextern.h, character.h,
+ charset.h, fontset.h.
+ * src/w32term.c: Don't include systty.h, systime.h, charset.h,
+ character.h, ccl.h, dispextern.h, disptab.h, intervals.h,
+ process.h, atimer.h, keymap.h, w32heap.h. Include bitmap/gray.xbm
+ in an ifdef-ed away block.
+ Include fcntl.h for CYGWIN.
+ (set_frame_param): Remove unused function.
+ * src/w32select.c: Don't include charset.h and composite.h.
+ (setup_config, Fw32_get_clipboard_data): Avoid compiler warnings
+ due to pointer signedness mismatches.
+ * src/w32reg.c (w32_get_string_resource): Avoid compiler warnings
+ due to pointer signedness mismatches.
+ * src/w32proc.c: Include unistd.h. Don't include systime.h,
+ process.h, dispextern.h.
+ (sys_spawnve, Fw32_short_file_name, Fw32_long_file_name)
+ (Fw32_application_type): Avoid compiler warnings due to pointer
+ signedness mismatches.
+ * src/w32menu.c: Don't include keymap.h, termhooks.h, window.h,
+ character.h, charset.h, dispextern.h.
+ (simple_dialog_show, add_menu_item): Avoid compiler warnings due
+ to pointer signedness mismatches.
+ * src/w32inevt.c: Don't include dispextern.h, window.h,
+ termhooks.h, w32heap.h.
+ * src/w32font.c: Don't include dispextern.h, character.h,
+ charset.h, fontset.h, font.h.
+ (intern_font_name, add_font_entity_to_list)
+ (registry_to_w32_charset, w32_to_x_charset, fill_in_logfont)
+ (list_all_matching_fonts): Avoid compiler warnings due to pointer
+ signedness mismatches.
+ * src/w32fns.c: Don't include character.h, intervals.h,
+ dispextern.h, epaths.h, charset.h, ccl.h, fontset.h, systime.h,
+ termhooks.h, w32heap.h, bitmap/gray.xbm, font.h, w32font.h.
+ (w32_color_map_lookup, add_system_logical_colors_to_map)
+ (x_decode_color, x_set_name, FPRINTF_WM_CHARS, Fxw_color_defined_p)
+ (Fxw_color_values, x_display_info_for_name, Fset_message_beep)
+ (x_create_tip_frame, Fx_file_dialog, Fsystem_move_file_to_trash)
+ (w32_parse_hot_key, Ffile_system_info, w32_kbd_patch_key): Avoid
+ compiler warnings, mainly due to pointer signedness mismatches.
+ (unwind_create_frame_1): Remove unused function.
+ * src/w32console.c: Don't include character.h, disptab.h, frame.h,
+ window.h, termhooks.h, dispextern.h.
+ (w32con_write_glyphs, w32con_write_glyphs_with_face): Fix pointer
+ signedness mismatch.
+ * src/w32.c: Include c-strcase.h and systty.h. Don't include
+ w32heap.h.
+
+2015-10-22 Tassilo Horn <address@hidden>
+
+ Improve doc-view wrt. auto-revert-mode
+
+ * lisp/doc-view.el (doc-view-revert-buffer): Don't revert when file
+ is corrupted (bug#21729).
+ (doc-view-mode): Set doc-view-revert-buffer as revert-buffer-function.
+
+2015-10-22 Oleh Krehel <address@hidden>
+
+ Describe dired-do-compress-to in the manual
+
+ * etc/NEWS: Update.
+
+ * lisp/dired-aux.el: Fix typo.
+
+ * doc/emacs/dired.texi: Add entry.
+
+2015-10-22 Jürgen Hötzel <address@hidden>
+
+ Further fix for proper locale handling in tramp-gvfs.el
+
+ * lisp/net/tramp-gvfs.el (tramp-gvfs-handle-file-attributes):
+ Just suppress LC_MESSAGES locale category settings.
+
+2015-10-21 Paul Eggert <address@hidden>
+
+ New lispref section “Security Considerations”
+
+ This attempts to document some of the issues recently discussed
+ on emacs-devel, and to indicate other such issues. The section
+ could be a lot longer.
+ * doc/lispref/os.texi (Security Considerations):
+ New node.
+ * doc/lispref/elisp.texi (Top):
+ * doc/lispref/processes.texi (Shell Arguments):
+ * lisp/subr.el (shell-quote-argument):
+ * src/callproc.c (syms_of_callproc):
+ Reference it.
+
+2015-10-21 Paul Eggert <address@hidden>
+
+ Merge from gnulib
+
+ This incorporates:
+ 2015-10-18 stdalign: work around pre-4.9 GCC x86 bug
+ 2015-10-18 time_rz: avoid warning from bleeding-edge gcc's -Wnonnull
+ * doc/misc/texinfo.tex, lib/stdalign.in.h, lib/time_rz.c:
+ Copy from gnulib.
+
+2015-10-21 Katsumi Yamaoka <address@hidden>
+
+ * lisp/gnus/mailcap.el (mailcap-mime-data): Remove fboundp checks.
+ (mailcap-viewer-passes-test): Do it instead. Thanks to Stefan Monnier.
+
+2015-10-21 Ken Brown <address@hidden>
+
+ Further include-file cleanup
+
+ * src/sheap.c: Include stdlib.h.
+ * src/unexcw.c: Include string.h.
+
+2015-10-21 Eli Zaretskii <address@hidden>
+
+ Fix logic in 'server-kill-emacs-query-function'
+
+ * lisp/server.el (server-kill-emacs-query-function): Correct the
+ logic that controls whether the user is asked for confirmation.
+ (Bug#21723)
+
+2015-10-21 Artur Malabarba <address@hidden>
+
+ * lisp/isearch.el (isearch-search-fun-default): Simplify logic.
+ (isearch--lax-regexp-function-p): New function.
+
+2015-10-21 Artur Malabarba <address@hidden>
+
+ * lisp/isearch.el: Support lax-whitespace in regexp-function searches.
+ (isearch-search-fun-default): Let-bind `search-spaces-regexp'
+ around `isearch-regexp-function'.
+
+2015-10-21 Artur Malabarba <address@hidden>
+
+ * lisp/isearch.el: Rename word search to regexp-function search.
+ `isearch-word' went well beyond its original purpose, and the name
+ no longer makes sense. It is now called
+ `isearch-regexp-function', and its value should always be a function
+ that converts a string to a regexp (though setting it to t is still
+ supported for now).
+ (isearch-word): Make obsolete.
+ (isearch-regexp-function): New variable.
+ (isearch-mode, isearch-done, isearch--state, isearch--set-state)
+ (with-isearch-suspended, isearch-toggle-regexp)
+ (isearch-toggle-word, isearch-toggle-symbol)
+ (isearch-toggle-character-fold, isearch-query-replace)
+ (isearch-occur, isearch-highlight-regexp)
+ (isearch-search-and-update, isearch-message-prefix)
+ (isearch-search-fun-default, isearch-search)
+ (isearch-lazy-highlight-new-loop, isearch-lazy-highlight-search):
+ Use it.
+ (isearch-lazy-highlight-regexp-function): New var.
+ (isearch-lazy-highlight-word): Make obsolete.
+ (isearch--describe-regexp-mode): New function.
+ (isearch--describe-word-mode): Make obsolete.
+
+ * lisp/info.el (Info-isearch-search):
+ * lisp/replace.el (replace-search, replace-highlight):
+ * lisp/obsolete/longlines.el (longlines-search-function):
+ * lisp/hexl.el (hexl-isearch-search-function):
+ * lisp/cedet/semantic/senator.el (senator-isearch-search-fun):
+ Use the new var.
+
+2015-10-21 Oleh Krehel <address@hidden>
+
+ Add dired-do-compress-to command bound to "c"
+
+ * lisp/dired-aux.el (dired-shell-command): Use the caller's
+ `default-directory', return the result of `process-file'.
+ (dired-compress-file-suffixes): Add comment on why "tar -zxf" isn't
+ used by default.
+ (dired-compress-files-alist): New defvar.
+ (dired-do-compress-to): New command.
+
+ * lisp/dired.el (dired-mode-map): Bind `dired-do-compress-to' to "c".
+ (dired-do-compress-to): Add an autoload entry.
+
+ * etc/NEWS: Add two entries.
+
+2015-10-21 Tassilo Horn <address@hidden>
+
+ Make RefTeX work with LaTeX subfiles package
+
+ * lisp/textmodes/reftex.el (reftex-TeX-master-file): Recognize subfiles
+ document class argument as master file for referencing purposes.
+
+2015-10-21 Katsumi Yamaoka <address@hidden>
+
+ * lisp/gnus/mailcap.el (mailcap-mailcap-entry-passes-test): Doc fix.
+
+2015-10-20 Paul Eggert <address@hidden>
+
+ Include-file cleanup for src directory
+
+ Omit ‘#include "foo.h"’ unless the file needs foo.h (Bug#21707).
+ In a few cases, add ‘#include "foo.h"’ if the file needs foo.h
+ but does not include it directly. As a general rule, a source
+ file should include foo.h if it needs the interfaces that foo.h
+ defines.
+ * src/alloc.c: Don’t include process.h. Include dispextern.h,
+ systime.h.
+ * src/atimer.c: Don’t include blockinput.h.
+ * src/buffer.c: Include coding.h, systime.h. Don’t include
+ keyboard.h, coding.h.
+ * src/callint.c: Don’t include commands.h, keymap.h.
+ * src/callproc.c: Don’t include character.h, ccl.h, composite.h,
+ systty.h, termhooks.h.
+ * src/casetab.c: Don’t include character.h.
+ * src/category.c: Don’t include charset.h, keymap.h.
+ * src/ccl.h: Don’t include character.h.
+ * src/character.c: Don’t include charset.h.
+ * src/charset.c: Don’t include disptab.h.
+ * src/chartab.c: Don’t include ccl.h.
+ * src/cm.c: Don’t include frame.h, termhooks.h.
+ * src/cmds.c: Don’t include window.h, dispextern.h.
+ * src/coding.c: Don’t include window.h, frame.h.
+ * src/composite.c: Include composite.h. Don’t include window.h,
+ font.h.
+ * src/data.c: Don’t include syssignal.h, termhooks.h, font.h.
+ * src/dbusbind.c: Don’t include frame.h.
+ * src/decompress.c: Don’t include character.h.
+ * src/dired.c: Don’t include character.h, commands.h, charset.h.
+ * src/dispnew.c: Don’t include character.h, indent.h, intervals.h,
+ process.h, timespec.h. Include systime.h.
+ * src/doc.c: Include coding.h. Don’t include keyboard.h.
+ * src/editfns.c: Include composite.h. Don’t include frame.h.
+ * src/emacs.c: Include fcntl.h, coding.h. Don’t include
+ commands.h, systty.h..
+ * src/fileio.c: Don’t include intervals.h, dispextern.h.
+ Include composite.h.
+ * src/filelock.c: Don’t include character.h, systime.h.
+ * src/fns.c: Don’t include time.h, commands.h, keyboard.h,
+ keymap.h, frame.h, blockinput.h, xterm.h. Include composite.h.
+ * src/font.c: Include termhooks.h.
+ * src/font.h: Don’t include ccl.h, frame.h. Add forward decls of
+ struct composition_it, struct face, struct glyph_string.
+ * src/fontset.c: Don’t include buffer.h, ccl.h, keyboard.h,
+ intervals.h, window.h, termhooks.h.
+ * src/frame.c: Don’t include character.h, commands.h, font.h.
+ * src/frame.h: Don’t include dispextern.h.
+ * src/fringe.c: Don’t include character.h.
+ * src/ftcrfont.c: Don’t include dispextern.h, frame.h,
+ character.h, charset.h, fontset.h.
+ * src/ftfont.c: Don’t include frame.h, blockinput.h, coding.h,
+ fontset.h.
+ * src/ftxfont.c: Don’t include dispextern.h, character.h,
+ charset.h, fontset.h.
+ * src/gfilenotify.c: Don’t include frame.h, process.h.
+ * src/gtkutil.c: Include dispextern.h, frame.h, systime.h.
+ Don’t include syssignal.h, buffer.h, charset.h, font.h.
+ * src/gtkutil.h: Don’t include frame.h.
+ * src/image.c: Include fcntl.h and stdio.h instead of sysstdio.h.
+ Don’t include character.h.
+ * src/indent.c: Don’t include keyboard.h, termchar.h.
+ * src/inotify.c: Don’t include character.h, frame.h.
+ * src/insdel.c: Include composite.h. Don’t include blockinput.h.
+ * src/intervals.c: Don’t include character.h, keyboard.h.
+ * src/intervals.h: Don’t include dispextern.h, composite.h.
+ * src/keyboard.c: Don’t include sysstdio.h, disptab.h, puresize.h.
+ Include coding.h.
+ * src/keyboard.h: Don’t incldue systime.h.
+ * src/keymap.c: Don’t include charset.h, frame.h.
+ * src/lread.c: Include dispextern.h and systime.h.
+ Don’t include frame.h. Include systime.h.
+ * src/macros.c: Don’t include commands.h, character.h, buffer.h.
+ * src/menu.c: Include character.h, coding.h. Don’t include
+ dispextern.h.
+ * src/menu.h: Don’t include systime.h.
+ * src/minibuf.c: Don’t include commands.h, dispextern.h, syntax.h,
+ intervals.h, termhooks.h.
+ * src/print.c: Include coding.h. Don’t include keyboard.h,
+ window.h, dispextern.h, termchar.h, termhooks.h, font.h.
+ Add forward decl of struct terminal.
+ * src/process.c: Don’t include termhooks.h, commands.h,
+ dispextern.h, composite.h.
+ * src/region-cache.c: Don’t include character.h.
+ * src/scroll.c: Don’t include keyboard.h, window.h.
+ * src/search.c: Don’t include category.h, commands.h.
+ * src/sound.c: Don’t include dispextern.h.
+ * src/syntax.c: Don’t include command.h, keymap.h.
+ * src/sysdep.c: Don’t include window.h, dispextern.h.
+ * src/systime.h: Use ‘#ifdef emacs’, not ‘#ifdef EMACS_LISP_H’,
+ * src/term.c: Don’t include systty.h, intervals.h, xterm.h.
+ * src/terminal.c: Include character.h.
+ Don’t include charset.h, coding.h.
+ * src/textprop.c: Don’t include character.h.
+ * src/undo.c: Don’t include character.h, commands.h, window.h.
+ * src/unexsol.c: Don’t include character.h, charset.h.
+ * src/widget.c: Include widget.h. Don’t include keyboard.h,
+ window.h, dispextern.h, blockinput.h, character.h, font.h.
+ * src/widgetprv.h: Don’t include widget.h.
+ * src/window.c: Don’t include character.h, menu.h, intervals.h.
+ * src/xdisp.c: Include composite.h, systime.h. Don’t include
+ macros.h, process.h.
+ * src/xfaces.c: Don’t include charset.h, keyboard.h, termhooks.h,
+ intervals.h.
+ * src/xfns.c: Don’t include menu.h, character.h, intervals.h,
+ epaths.h, fontset.h, systime.h, atimer.h, termchar.h.
+ * src/xfont.c: Don’t include dispextern.h, fontset.h, ccl.h.
+ * src/xftfont.c: Don’t include dispextern.h, character.h, fontset.h.
+ * src/xgselect.c: Don’t include timespec.h, frame.h.
+ Include systime.h.
+ * src/xgselect.h: Don’t include time.h.
+ Use a forward decl to struct timespec instead.
+ * src/xmenu.c: Don’t include keymap.h, character.h, charset.h,
+ dispextern.h. Include systime.h.
+ * src/xml.c: Don’t include character.h.
+ * src/xrdb.c [USE_MOTIF]: Don’t include keyboard.h.
+ * src/xselect.c: Don’t include dispextern.h, character.h,
+ buffer.h, process.h.
+ * src/xsmfns.c: Don’t include systime.h, sysselect.h.
+ * src/xterm.c: Don’t include syssignal.h, charset.h, disptab.h,
+ intervals.h process.h, keymap.h, xgselect.h. Include composite.h.
+
+2015-10-20 Paul Eggert <address@hidden>
+
+ (/ N) now returns the reciprocal of N
+
+ This is more compatible with Common Lisp and XEmacs (Bug#21690). See:
+ http://lists.gnu.org/archive/html/emacs-devel/2015-10/msg01053.html
+ * lisp/color.el (color-hue-to-rgb, color-hsl-to-rgb)
+ (color-xyz-to-srgb, color-xyz-to-lab):
+ * lisp/emacs-lisp/cl-extra.el (cl-float-limits):
+ * lisp/net/shr-color.el (shr-color-hue-to-rgb)
+ (shr-color-hsl-to-rgb-fractions):
+ Exploit the change to simplify the code a bit.
+ * lisp/emacs-lisp/bytecomp.el (byte-compile-quo):
+ Don’t complain about single-argument calls to ‘/’.
+ * src/data.c (arith_driver, float_arith_driver):
+ Implement the change.
+
+2015-10-20 Dmitry Gutov <address@hidden>
+
+ Call vc-dir-refresh after stash operations
+
+ * lisp/vc/vc-git.el (vc-git-stash-apply-at-point)
+ (vc-git-stash-pop-at-point): Call vc-dir-refresh (bug#13960).
+
+ * lisp/vc/vc-dir.el (vc-dir-resynch-file): Expand FNAME as well,
+ since it can be abbreviated (as returned by vc-find-root).
+
+2015-10-20 Dmitry Gutov <address@hidden>
+
+ * lisp/vc/vc-svn.el:
+ * lisp/vc/vc-mtn.el:
+ * lisp/vc/vc-hg.el:
+ * lisp/vc/vc-cvs.el:
+ * lisp/vc/vc-git.el:
+ * lisp/vc/vc-bzr.el: Don't declare vc-exec-after anymore.
+ Its usages have been replaced with vc-run-delayed.
+
+2015-10-20 Dima Kogan <address@hidden>
+
+ Fix memory leak in fontset handling
+
+ * src/font.c (copy_font_spec): Make a deep copy of the input
+ argument FONT. (Bug#21651)
+
+2015-10-20 Michael Sperber <address@hidden>
+
+ * lisp/gnus/mailcap.el (mailcap-mime-data):
+ Conditonalize `doc-view-mode', which does not exist on XEmacs.
+
+2015-10-20 Oleh Krehel <address@hidden>
+
+ Update the way directories are compressed
+
+ * lisp/dired-aux.el (dired-compress-file-suffixes): Update the recipe
+ for *.tar.gz decompression to use a pipe.
+ Add an entry for the default directory compression (to *.tar.g).
+ (dired-compress-file): Update.
+
+ See
https://lists.gnu.org/archive/html/emacs-devel/2015-10/msg00949.html.
+
+2015-10-20 Michael Sperber <address@hidden>
+
+ Unbreak `group' option for `mail-sources'
+
+ * nnml.el (nnml-retrieve-groups, nnml-request-scan):
+ * nnmail.el (nnmail-get-new-mail-per-group)
+ (nnmail-get-new-mail-1): Unbreak `group' option for `mail-sources'.
+
+2015-10-19 Nicolas Petton <address@hidden>
+
+ New function seq-position
+
+ * lisp/emacs-lisp/seq.el (seq-position): New function.
+ * test/automated/seq-tests.el: New tests for seq-position.
+ * doc/lispref/sequences.texi: Add documentation for `seq-position'.
+
+2015-10-19 Ken Brown <address@hidden>
+
+ Enable --with-wide-int build on 32-bit Cygwin
+
+ * src/sheap.c (STATIC_HEAP_SIZE): Remove distinction between x86
+ and x86_64 to enable --with-wide-int build on 32-bit Cygwin.
+
+2015-10-19 Glenn Morris <address@hidden>
+
+ * doc/emacs/ack.texi (Acknowledgments): Small, sad, update.
+
+2015-10-19 Eli Zaretskii <address@hidden>
+
+ Resurrect image loading under auto-image-file-mode
+
+ * src/image.c (x_find_image_fd): Handle the case of -2 returned by
+ 'openp' specially. This special case was lost in the changes on
+ 2015-08-18. (Bug#21685)
+
+2015-10-19 Eli Zaretskii <address@hidden>
+
+ Fix return value of 'set-file-extended-attributes'
+
+ * lisp/files.el (set-file-extended-attributes): Return non-nil
+ when setting either ACLs or SELinux context succeeds. Document
+ the return value. (Bug#21699)
+
+ * doc/lispref/files.texi (Changing Files): Document the return
+ value of set-file-extended-attributes.
+
+2015-10-19 Eli Zaretskii <address@hidden>
+
+ Improve documentation of functions that change files
+
+ * doc/lispref/files.texi (Changing Files): Document that these
+ functions signal an error on failure.
+
+2015-10-18 Eli Zaretskii <address@hidden>
+
+ Fix doc string of 'shell-quote-argument'
+
+ * lisp/subr.el (shell-quote-argument): Doc fix. (Bug#21702)
+
+2015-10-18 Michael Albinus <address@hidden>
+
+ Some minor Tramp changes
+
+ * doc/misc/tramp.texi (Obtaining Tramp): Add http git cloning.
+
+ * lisp/net/tramp.el (tramp-handle-make-auto-save-file-name):
+ Expand `tramp-auto-save-directory'.
+
2015-10-18 Michael Albinus <address@hidden>
Minor edits in Tramp
@@ -15680,7 +16535,7 @@
This file records repository revisions from
commit 9d56a21e6a696ad19ac65c4b405aeca44785884a (exclusive) to
-commit f8ff3937660f4192d72dec2da31fa5c582434d1f (inclusive).
+commit 0afbc5b2a2cda9fe12246bf62567162ae2577160 (inclusive).
See ChangeLog.1 for earlier changes.
;; Local Variables:
diff --git a/doc/lispref/files.texi b/doc/lispref/files.texi
index ca8abe5..65a97a4 100644
--- a/doc/lispref/files.texi
+++ b/doc/lispref/files.texi
@@ -2038,32 +2038,35 @@ forward slash (@samp{/}) character.
@node Directory Names
@subsection Directory Names
@cindex directory name
address@hidden directory file name
@cindex file name of directory
A @dfn{directory name} is the name of a directory. A directory is
-actually a kind of file, so it has a file name, which is related to
-the directory name but not identical to it. (This is not quite the
-same as the usual Unix terminology.) These two different names for
-the same entity are related by a syntactic transformation. On GNU and
-Unix systems, this is simple: a directory name ends in a slash,
-whereas the directory's name as a file lacks that slash. On MS-DOS
-the relationship is more complicated.
-
- The difference between a directory name and its name as a file is
+actually a kind of file, so it has a file name (called the
address@hidden file name}, which is related to the directory name but
+not identical to it. (This is not quite the same as the usual Unix
+terminology.) These two different names for the same entity are
+related by a syntactic transformation. On GNU and Unix systems, this
+is simple: a directory name ends in a slash, whereas the directory
+file name lacks that slash. On MS-DOS the relationship is more
+complicated.
+
+ The difference between directory name and directory file name is
subtle but crucial. When an Emacs variable or function argument is
-described as being a directory name, a file name of a directory is not
+described as being a directory name, a directory file name is not
acceptable. When @code{file-name-directory} returns a string, that is
always a directory name.
- The following two functions convert between directory names and file
-names. They do nothing special with environment variable substitutions
-such as @samp{$HOME}, and the constructs @samp{~}, @samp{.} and @samp{..}.
+ The following two functions convert between directory names and
+directory file names. They do nothing special with environment
+variable substitutions such as @samp{$HOME}, and the constructs
address@hidden, @samp{.} and @samp{..}.
@defun file-name-as-directory filename
This function returns a string representing @var{filename} in a form
-that the operating system will interpret as the name of a directory. On
-most systems, this means appending a slash to the string (if it does not
-already end in one).
+that the operating system will interpret as the name of a directory (a
+directory name). On most systems, this means appending a slash to the
+string (if it does not already end in one).
@example
@group
@@ -2074,10 +2077,10 @@ already end in one).
@end defun
@defun directory-file-name dirname
-This function returns a string representing @var{dirname} in a form that
-the operating system will interpret as the name of a file. On most
-systems, this means removing the final slash (or backslash) from the
-string.
+This function returns a string representing @var{dirname} in a form
+that the operating system will interpret as the name of a file (a
+directory file name). On most systems, this means removing the final
+slash (or backslash) from the string.
@example
@group
@@ -2119,6 +2122,13 @@ Don't try concatenating a slash by hand, as in
because this is not portable. Always use
@code{file-name-as-directory}.
+ To avoid the issues mentioned above, or if the @var{dirname} value
+might be nil (for example, from an element of @code{load-path}), use:
+
address@hidden
+(expand-file-name @var{relfile} @var{dirname})
address@hidden example
+
To convert a directory name to its abbreviation, use this
function:
diff --git a/doc/lispref/os.texi b/doc/lispref/os.texi
index 1925bd5..7050df8 100644
--- a/doc/lispref/os.texi
+++ b/doc/lispref/os.texi
@@ -2632,6 +2632,8 @@ reports attribute changes as well
@var{file} has been renamed to @var{file1}
@item attribute-changed
a @var{file} attribute was changed
address@hidden stopped
+watching @var{file} has been stopped
@end table
Note that the @file{w32notify} library does not report
@@ -2639,6 +2641,11 @@ Note that the @file{w32notify} library does not report
permissions or modification time, has changed, this library reports a
@code{changed} event.
+The @code{stopped} event reports, that watching the file has been
+stopped. This could be because @code{file-notify-rm-watch} was called
+(see below), or because the file being watched was deleted, or due to
+another error reported from the underlying library.
+
@var{file} and @var{file1} are the name of the file(s) whose event is
being reported. For example:
@@ -2690,6 +2697,11 @@ watch library. Otherwise, the actions @code{deleted} and
(rename-file "/tmp/foo" "/tmp/bla")
@result{} Event (35025468 renamed "/tmp/foo" "/tmp/bla")
@end group
+
address@hidden
+(delete-file "/tmp/bla")
+ @result{} Event (35025468 deleted "/tmp/bla")
address@hidden group
@end example
@end defun
@@ -2708,6 +2720,60 @@ A watch can become invalid if the file or directory it
watches is
deleted, or if the watcher thread exits abnormally for any other
reason. Removing the watch by calling @code{file-notify-rm-watch}
also makes it invalid.
+
address@hidden
address@hidden
+(make-directory "/tmp/foo")
+ @result{} nil
address@hidden group
+
address@hidden
+(setq desc
+ (file-notify-add-watch
+ "/tmp/foo" '(change) 'my-notify-callback))
+ @result{} 35025468
address@hidden group
+
address@hidden
+(file-notify-valid-p desc)
+ @result{} t
address@hidden group
+
address@hidden
+(write-region "bla" nil "/tmp/foo/bla")
+ @result{} Event (35025468 created "/tmp/foo/.#bla")
+ Event (35025468 created "/tmp/foo/bla")
+ Event (35025468 changed "/tmp/foo/bla")
+ Event (35025468 changed "/tmp/foo/.#bla")
address@hidden group
+
address@hidden
+;; Deleting a file in the directory doesn't invalidate the watch.
+(delete-file "/tmp/foo/bla")
+ @result{} Event (35025468 deleted "/tmp/foo/bla")
address@hidden group
+
address@hidden
+(write-region "bla" nil "/tmp/foo/bla")
+ @result{} Event (35025468 created "/tmp/foo/.#bla")
+ Event (35025468 created "/tmp/foo/bla")
+ Event (35025468 changed "/tmp/foo/bla")
+ Event (35025468 changed "/tmp/foo/.#bla")
address@hidden group
+
address@hidden
+;; Deleting the directory invalidates the watch.
+(delete-directory "/tmp/foo" 'recursive)
+ @result{} Event (35025468 deleted "/tmp/foo/bla")
+ Event (35025468 deleted "/tmp/foo")
+ Event (35025468 stopped "/tmp/foo")
address@hidden group
+
address@hidden
+(file-notify-valid-p desc)
+ @result{} nil
address@hidden group
address@hidden example
@end defun
@node Dynamic Libraries
diff --git a/doc/lispref/sequences.texi b/doc/lispref/sequences.texi
index 8ecae7b..84a7c32 100644
--- a/doc/lispref/sequences.texi
+++ b/doc/lispref/sequences.texi
@@ -572,6 +572,24 @@ element of @var{sequence}. The returned value is a list.
@end example
@end defun
address@hidden seq-mapn function &rest sequences
+ This function returns the result of applying @var{function} to each
+element of @var{sequences}. The arity of @var{function} must match
+the number of sequences. Mapping stops at the shortest sequence, and
+the returned value is a list.
+
address@hidden
address@hidden
+(seq-mapn #'+ '(2 4 6) '(20 40 60))
address@hidden (22 44 66)
address@hidden group
address@hidden
+(seq-mapn #'concat '("moskito" "bite") ["bee" "sting"])
address@hidden ("moskitobee" "bitesting")
address@hidden group
address@hidden example
address@hidden defun
+
@defun seq-filter predicate sequence
@cindex filtering sequences
This function returns a list of all the elements in @var{sequence}
diff --git a/etc/NEWS b/etc/NEWS
index 8672f99..47a4bae 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -81,6 +81,10 @@ be installed setgid. The option now defaults to the 'games'
group.
It has no particular connection to Emacs and has not changed in years,
so if you want to use it, you can always take a copy from an older Emacs.
+** Emacs 25 comes with a new set of icons.
+Various resolutions are available as etc/images/icons/hicolor/*/apps/emacs.png.
+The old Emacs logo icons are available as `emacs23.png' in the same location.
+
* Startup Changes in Emacs 25.1
@@ -111,6 +115,8 @@ frames.
** New doc command `describe-symbol'. Works for functions, vars, faces, etc...
+** New user option `search-default-regexp-mode' specifies the default mode for
isearch
+
** `isearch' and `query-replace' now perform character folding in matches.
This is analogous to case-folding, but applies between Unicode
characters and their ASCII counterparts. This means many characters
@@ -275,14 +281,6 @@ header.
** `tabulated-list-print' takes a second optional argument, update,
which specifies an alternative printing method which is faster when
few or no entries have changed.
-** The command `dired-do-compress' bound to `Z' now can compress
-directories and decompress zip files.
-** New command `dired-do-compress-to' bound to `c' can be used to compress
-many marked files into a single named archive. The compression
-command is determined from the new `dired-compress-files-alist'
-variable.
-
-+++
* Editing Changes in Emacs 25.1
@@ -567,17 +565,6 @@ appending FUN to `minibuffer-setup-hook'.
** cl-lib
*** New functions cl-fresh-line, cl-digit-char-p and cl-parse-integer.
-** seq
-*** New seq library:
-The seq library adds sequence manipulation functions and macros that
-complement basic functions provided by subr.el. All functions are
-prefixed with `seq-' and work on lists, strings and vectors.
-
-** map
-*** New map library:
-The map library provides map-manipulation functions that work on alists,
-hash-table and arrays. All functions are prefixed with "map-".
-
** Calendar and diary
+++
@@ -858,10 +845,27 @@ be added to the archive.
** Autorevert: dired buffers are also auto-reverted via file
notifications, if Emacs is compiled with file notification support.
+** File Notifications
+
++++
+*** The new event `stopped' signals, that a file notification watch is
+not active any longer.
+
+++
-** File Notifications: the new function `file-notify-valid-p' checks,
-whether a file notification descriptor still corresponds to an
-activate watch.
+*** The new function `file-notify-valid-p' checks, whether a file
+notification descriptor still corresponds to an activate watch.
+
+** Dired
+
++++
+*** The command `dired-do-compress' bound to `Z' now can compress
+directories and decompress zip files.
+
++++
+*** New command `dired-do-compress-to' bound to `c' can be used to
+compress many marked files into a single named archive. The
+compression command is determined from the new
+`dired-compress-files-alist' variable.
** Obsolete packages
@@ -891,6 +895,18 @@ types the text. Breaking line after a single-character
words is
forbidden by Czech and Polish typography (and may be discouraged in
other languages), so `auto-tildify-mode' makes it easier to create
a typographically-correct documents.
+
+** The `seq' library adds sequence manipulation functions and macros
+that complement basic functions provided by subr.el. All functions
+are prefixed with `seq-' and work on lists, strings and vectors.
+
+** The `map' library provides map-manipulation functions that work on
+alists, hash-table and arrays. All functions are prefixed with
+`map-'.
+
+** The `thunk' library provides functions and macros to control the
+evaluation of forms.
+
* Incompatible Lisp Changes in Emacs 25.1
diff --git a/etc/images/icons/README b/etc/images/icons/README
index 70979dd..2010bf2 100644
--- a/etc/images/icons/README
+++ b/etc/images/icons/README
@@ -3,6 +3,15 @@ COPYRIGHT AND LICENSE INFORMATION FOR IMAGE FILES
Files: hicolor/16x16/apps/emacs.png hicolor/24x24/apps/emacs.png
hicolor/32x32/apps/emacs.png hicolor/48x48/apps/emacs.png
hicolor/128x128/apps/emacs.png hicolor/scalable/apps/emacs.svg
+ hicolor/scalable/mimetypes/emacs-document.svg
+
+Author: Nicolas Petton <address@hidden>
+Copyright (C) 2015 Free Software Foundation, Inc.
+License: GNU General Public License version 3 or later (see COPYING)
+
+Files: hicolor/16x16/apps/emacs23.png hicolor/24x24/apps/emacs23.png
+ hicolor/32x32/apps/emacs23.png hicolor/48x48/apps/emacs23.png
+ hicolor/128x128/apps/emacs23.png hicolor/scalable/apps/emacs23.svg
Author: Kentaro Ohkouchi <address@hidden>
Copyright (C) 2007-2015 Free Software Foundation, Inc.
diff --git a/etc/images/icons/hicolor/128x128/apps/emacs.png
b/etc/images/icons/hicolor/128x128/apps/emacs.png
index 5e2ff74..9ab43d7 100644
Binary files a/etc/images/icons/hicolor/128x128/apps/emacs.png and
b/etc/images/icons/hicolor/128x128/apps/emacs.png differ
diff --git a/etc/images/icons/hicolor/128x128/apps/emacs.png
b/etc/images/icons/hicolor/128x128/apps/emacs23.png
similarity index 100%
copy from etc/images/icons/hicolor/128x128/apps/emacs.png
copy to etc/images/icons/hicolor/128x128/apps/emacs23.png
diff --git a/etc/images/icons/hicolor/16x16/apps/emacs.png
b/etc/images/icons/hicolor/16x16/apps/emacs.png
index 48280fe..eb6b402 100644
Binary files a/etc/images/icons/hicolor/16x16/apps/emacs.png and
b/etc/images/icons/hicolor/16x16/apps/emacs.png differ
diff --git a/etc/images/icons/hicolor/16x16/apps/emacs.png
b/etc/images/icons/hicolor/16x16/apps/emacs23.png
similarity index 100%
copy from etc/images/icons/hicolor/16x16/apps/emacs.png
copy to etc/images/icons/hicolor/16x16/apps/emacs23.png
diff --git a/etc/images/icons/hicolor/24x24/apps/emacs.png
b/etc/images/icons/hicolor/24x24/apps/emacs.png
index d17c6b1..7a8d8b6 100644
Binary files a/etc/images/icons/hicolor/24x24/apps/emacs.png and
b/etc/images/icons/hicolor/24x24/apps/emacs.png differ
diff --git a/etc/images/icons/hicolor/24x24/apps/emacs.png
b/etc/images/icons/hicolor/24x24/apps/emacs23.png
similarity index 100%
copy from etc/images/icons/hicolor/24x24/apps/emacs.png
copy to etc/images/icons/hicolor/24x24/apps/emacs23.png
diff --git a/etc/images/icons/hicolor/32x32/apps/emacs.png
b/etc/images/icons/hicolor/32x32/apps/emacs.png
index 53ba5c6..aea5afd 100644
Binary files a/etc/images/icons/hicolor/32x32/apps/emacs.png and
b/etc/images/icons/hicolor/32x32/apps/emacs.png differ
diff --git a/etc/images/icons/hicolor/32x32/apps/emacs.png
b/etc/images/icons/hicolor/32x32/apps/emacs23.png
similarity index 100%
copy from etc/images/icons/hicolor/32x32/apps/emacs.png
copy to etc/images/icons/hicolor/32x32/apps/emacs23.png
diff --git a/etc/images/icons/hicolor/48x48/apps/emacs.png
b/etc/images/icons/hicolor/48x48/apps/emacs.png
index f2917e3..bae23aa 100644
Binary files a/etc/images/icons/hicolor/48x48/apps/emacs.png and
b/etc/images/icons/hicolor/48x48/apps/emacs.png differ
diff --git a/etc/images/icons/hicolor/48x48/apps/emacs.png
b/etc/images/icons/hicolor/48x48/apps/emacs23.png
similarity index 100%
copy from etc/images/icons/hicolor/48x48/apps/emacs.png
copy to etc/images/icons/hicolor/48x48/apps/emacs23.png
diff --git a/etc/images/icons/hicolor/scalable/apps/emacs.svg
b/etc/images/icons/hicolor/scalable/apps/emacs.svg
index 7af85ce..5274204 100644
--- a/etc/images/icons/hicolor/scalable/apps/emacs.svg
+++ b/etc/images/icons/hicolor/scalable/apps/emacs.svg
@@ -1,17 +1,24 @@
<?xml version="1.0" encoding="UTF-8" standalone="no"?>
<svg
+ xmlns:dc="http://purl.org/dc/elements/1.1/";
+ xmlns:cc="http://creativecommons.org/ns#";
+ xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#";
xmlns:svg="http://www.w3.org/2000/svg";
xmlns="http://www.w3.org/2000/svg";
xmlns:xlink="http://www.w3.org/1999/xlink";
- version="1.0"
- width="48"
- height="48"
- viewBox="0.171 0.201 512 512"
+ xml:space="preserve"
id="svg4768"
- xml:space="preserve">
-<!-- Gnu Emacs Icon
+ viewBox="0.171 0.201 512 512"
+ height="48"
+ width="48"
+ version="1.0"><metadata
+ id="metadata70"><rdf:RDF><cc:Work
+ rdf:about=""><dc:format>image/svg+xml</dc:format><dc:type
+ rdf:resource="http://purl.org/dc/dcmitype/StillImage";
/><dc:title></dc:title></cc:Work></rdf:RDF></metadata><!-- Gnu Emacs Icon
Copyright (C) 2008-2015 Free Software Foundation, Inc.
+ Author: Nicolas Petton <address@hidden>
+
This file is part of GNU Emacs.
GNU Emacs is free software: you can redistribute it and/or modify
@@ -27,268 +34,253 @@
You should have received a copy of the GNU General Public License
along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
--->
-<!-- Created with Inkscape (http://www.inkscape.org/) -->
-<defs
- id="defs4770"><linearGradient
- id="linearGradient3294"><stop
- id="stop3296"
- style="stop-color:#6376e6;stop-opacity:1"
- offset="0" /><stop
- id="stop3302"
- style="stop-color:#222989;stop-opacity:1"
- offset="0.50094414" /><stop
- id="stop3298"
- style="stop-color:#00003d;stop-opacity:1"
- offset="1" /></linearGradient><linearGradient
- id="linearGradient3284"><stop
- id="stop3286"
- style="stop-color:#000000;stop-opacity:1"
- offset="0" /><stop
- id="stop3292"
- style="stop-color:#000000;stop-opacity:0.49803922"
- offset="0.84845906" /><stop
- id="stop3288"
- style="stop-color:#000000;stop-opacity:0"
- offset="1" /></linearGradient><linearGradient
- id="linearGradient3274"><stop
- id="stop3276"
- style="stop-color:#000000;stop-opacity:1"
- offset="0" /><stop
- id="stop3278"
- style="stop-color:#000000;stop-opacity:0"
- offset="1" /></linearGradient><linearGradient
- id="linearGradient3262"><stop
- id="stop3264"
- style="stop-color:#000000;stop-opacity:1"
- offset="0" /><stop
- id="stop3266"
- style="stop-color:#000000;stop-opacity:0"
- offset="1" /></linearGradient><linearGradient
- id="linearGradient3242"><stop
- id="stop3244"
- style="stop-color:#282828;stop-opacity:1"
- offset="0" /><stop
- id="stop3252"
- style="stop-color:#808080;stop-opacity:1"
- offset="0.39253417" /><stop
- id="stop3246"
- style="stop-color:#d9d9d9;stop-opacity:1"
- offset="1" /></linearGradient><linearGradient
- id="linearGradient3202"><stop
- id="stop3204"
- style="stop-color:#2b2b2b;stop-opacity:1"
- offset="0" /><stop
- id="stop3250"
- style="stop-color:#828383;stop-opacity:1"
- offset="0.5" /><stop
- id="stop3206"
- style="stop-color:#dadbdb;stop-opacity:1"
- offset="1" /></linearGradient><linearGradient
- id="linearGradient4966"><stop
- id="stop4968"
- style="stop-color:#b6b3d8;stop-opacity:1"
- offset="0" /><stop
- id="stop4970"
- style="stop-color:#b6b3d8;stop-opacity:0"
- offset="1" /></linearGradient><linearGradient
- id="linearGradient4938"><stop
- id="stop4940"
- style="stop-color:#000000;stop-opacity:1"
- offset="0" /><stop
- id="stop4942"
- style="stop-color:#000000;stop-opacity:0"
- offset="1" /></linearGradient><linearGradient
- id="linearGradient4898"><stop
- id="stop4900"
- style="stop-color:#bab8db;stop-opacity:1"
- offset="0" /><stop
- id="stop4902"
- style="stop-color:#5955a9;stop-opacity:0.99159664"
- offset="1" /></linearGradient><linearGradient
- id="linearGradient4876"><stop
- id="stop4878"
- style="stop-color:#d3d2e8;stop-opacity:1"
- offset="0" /><stop
- id="stop4880"
- style="stop-color:#5955a9;stop-opacity:0.99159664"
- offset="1" /></linearGradient>
-<radialGradient
- cx="20.951529"
- cy="-108.96888"
- r="266.76535"
- fx="20.951529"
- fy="-108.96888"
- id="radialGradient4892"
- xlink:href="#linearGradient4898"
- gradientUnits="userSpaceOnUse"
- gradientTransform="matrix(0.6817439,0,0,0.5905355,-3.8523706,-28.935273)"
/><radialGradient
- cx="233.8876"
- cy="471.26172"
- r="170.49393"
- fx="233.8876"
- fy="471.26172"
- id="radialGradient4944"
- xlink:href="#linearGradient4938"
- gradientUnits="userSpaceOnUse"
- gradientTransform="matrix(1,0,0,0.1854103,0,383.88493)" /><radialGradient
- cx="299.70135"
- cy="371.76376"
- r="76.696358"
- fx="299.70135"
- fy="371.76376"
- id="radialGradient4972"
- xlink:href="#linearGradient4966"
- gradientUnits="userSpaceOnUse"
- gradientTransform="matrix(1,0,0,0.9121621,0,32.654948)" /><radialGradient
- cx="289.44067"
- cy="390.45248"
- r="17.67668"
- fx="289.44067"
- fy="390.45248"
- id="radialGradient3210"
- xlink:href="#linearGradient3202"
- gradientUnits="userSpaceOnUse"
-
gradientTransform="matrix(0.414705,0.3300575,-0.5059004,0.6356454,346.95314,49.479585)"
/><radialGradient
- cx="283.50717"
- cy="382.14804"
- r="17.67668"
- fx="283.50717"
- fy="382.14804"
- id="radialGradient3238"
- xlink:href="#linearGradient3202"
- gradientUnits="userSpaceOnUse"
-
gradientTransform="matrix(0.414705,0.3300575,-0.5059004,0.6356454,448.41009,-65.398074)"
/><radialGradient
- cx="418.45551"
- cy="181.18982"
- r="63.068935"
- fx="418.45551"
- fy="181.18982"
- id="radialGradient3248"
- xlink:href="#linearGradient3242"
- gradientUnits="userSpaceOnUse"
-
gradientTransform="matrix(-6.5565014e-2,-5.9721765e-2,1.6871024,-1.8521705,171.90774,540.51473)"
/><radialGradient
- cx="354.51709"
- cy="357.33591"
- r="33.712105"
- fx="354.51709"
- fy="357.33591"
- id="radialGradient3268"
- xlink:href="#linearGradient3262"
- gradientUnits="userSpaceOnUse"
-
gradientTransform="matrix(0.4055116,-3.3440123e-2,0.1034174,4.3988695,177.23251,-1191.6649)"
/><radialGradient
- cx="510.58469"
- cy="223.55537"
- r="132.28336"
- fx="510.58469"
- fy="223.55537"
- id="radialGradient3280"
- xlink:href="#linearGradient3274"
- gradientUnits="userSpaceOnUse"
-
gradientTransform="matrix(-0.1339874,-0.1146812,0.3079048,-0.3597394,444.23592,395.03849)"
/><radialGradient
- cx="284.4671"
- cy="-158.17821"
- r="110.2972"
- fx="284.4671"
- fy="-158.17821"
- id="radialGradient3290"
- xlink:href="#linearGradient3284"
- gradientUnits="userSpaceOnUse"
-
gradientTransform="matrix(-1.2497569,1.3798305,-9.6289463e-2,-7.2974479e-2,674.3826,-70.590682)"
/><radialGradient
- cx="425.51019"
- cy="356.62274"
- r="143.34167"
- fx="425.51019"
- fy="356.62274"
- id="radialGradient3300"
- xlink:href="#linearGradient3294"
- gradientUnits="userSpaceOnUse"
-
gradientTransform="matrix(-0.1008165,-8.0872321e-2,1.0745309,-1.3395252,13.843287,784.79288)"
/></defs>
-<path
- d="M 404.38153,471.26172 C 404.40061,488.72268 328.06229,502.87946
233.8876,502.87946 C 139.71291,502.87946 63.374595,488.72268
63.393677,471.26172 C 63.374595,453.80076 139.71291,439.64398
233.8876,439.64398 C 328.06229,439.64398 404.40061,453.80076
404.38153,471.26172 z"
- transform="matrix(1.3434649,0,0,1.3934426,-81.886873,-193.70595)"
- id="path4912"
-
style="opacity:1;fill:url(#radialGradient4944);fill-opacity:1;stroke:#7b0000;stroke-width:0;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
/><path
- d="M 277.19656,7.985198 C 277.19656,165.02971 157.76164,292.33945
10.43121,292.33945 C -136.89922,292.33945 -256.33414,165.02971
-256.33414,7.985198 C -256.33414,-149.05932 -136.89922,-276.36905
10.43121,-276.36905 C 157.76164,-276.36905 277.19656,-149.05932
277.19656,7.985198 z"
- transform="matrix(0.8855031,0,0,0.8392166,227.80221,232.6491)"
- id="path4864"
-
style="opacity:1;fill:url(#radialGradient4892);fill-opacity:1;stroke:#7b0000;stroke-width:0;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
/><path
- d="M 376.39771,371.76376 C 376.40956,410.40897 342.06796,441.74284
299.70135,441.74284 C 257.33475,441.74284 222.99315,410.40897 223.005,371.76376
C 222.99315,333.11855 257.33475,301.78468 299.70135,301.78468 C
342.06796,301.78468 376.40956,333.11855 376.39771,371.76376 L
376.39771,371.76376 z"
- transform="matrix(1.4594595,0,0,1,-195.74111,-13.473684)"
- id="path4946"
-
style="opacity:1;fill:url(#radialGradient4972);fill-opacity:1;stroke:#7b0000;stroke-width:0;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
/><path
- d="M 120.52728,395.60181 C 120.52728,395.60181 141.53508,401.7017
169.49894,405.18885 C 180.82361,406.60106 223.91189,411.53703
256.94833,411.40748 C 256.94833,411.40748 297.18385,411.45315
319.39367,408.29817 C 342.63265,404.99699 355.79853,400.78399
363.12576,392.37646 C 363.31663,390.37182 366.66239,383.83735
357.62922,377.53581 C 334.53496,361.42524 304.67924,357.01539
246.68812,343.24332 C 182.56112,327.12062 163.39684,311.68183
153.82282,300.50869 C 144.74597,289.31078 155.52664 [...]
- id="path4839"
-
style="fill:#ffffff;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
/><rect
- width="512"
- height="512"
- x="0.171"
- y="0.20100001"
- id="rect4772"
- style="fill:none;display:none" />
-
-
-
-<g
- id="g4788"
- style="display:none">
- <g
- id="g4790"
- style="display:inline">
- </g>
-</g>
-
-
-<g
- id="g4806"
- style="display:none">
- <g
- id="g4808"
- style="display:inline">
- <path
- d="M 349.098,256.651 C 348.833,256.397 386.735,284.256 388.519,281.663 C
394.881,272.411 470.565,188.526 473.303,165.427 C 473.545,163.424
472.787,161.331 472.787,161.331 C 472.787,161.331 471.597,161.187
466.462,157.017 C 463.77,154.825 460.979,152.436 460.979,152.436 C
444.925,153.434 403.094,193.995 349.917,256.004"
- id="path4810"
- style="fill:#050505;display:none" />
- </g>
-</g>
-
-
-
-<g
- id="g4796"
- style="stroke:none">
-
- <g
- id="g4800"
- style="stroke:none">
-
- </g>
-</g><g
- id="g4820">
-
- <path
- d="M 279.476,404.243 C 279.469,404.239 272.03,400.131 262.672,392.842 L
262.672,392.842 C 254.59,386.557 249.134,380.628 249.128,380.622 L
249.128,380.622 L 249.006,380.489 L 252.652,375.82 L 252.809,375.615 L
252.978,375.812 C 252.995,375.822 258.378,382.107 266.703,388.592 L
266.703,388.592 C 274.616,394.749 283.297,399.178 283.315,399.187 L
283.315,399.187 L 283.544,399.304 L 279.633,404.33 L 279.476,404.243 L
279.476,404.243 z M 262.934,392.506 C 271.479,399.162 278.403,403.15 279 [...]
- id="path4824"
- style="fill:#4d4d4d" />
-</g><g
- id="g4774">
-
-</g><rect
- width="378.89471"
- height="389.88782"
- x="129.8893"
- y="112.05299"
- id="rect3282"
-
style="opacity:1;fill:url(#radialGradient3290);fill-opacity:1;stroke:#4a4a4a;stroke-width:0;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
/><path
- d="M 279.41935,402.42925 C 279.41935,402.42925 332.64609,345.32574
384.74548,282.44569 L 387.0212,283.14836 C 387.0212,283.14836
495.06978,164.73541 468.64063,155.14837 C 468.64063,155.14837
455.42606,128.97833 351.78234,254.90545 L 351.58303,256.79518 C
303.76315,311.94378 250.62994,379.18477 250.62994,379.18477 C
209.58912,438.18094 185.22113,481.78682 187.23653,486.00083 C
189.97605,491.72893 279.57838,403.0031 279.41935,402.42925 z"
- id="path3254"
-
style="fill:url(#radialGradient3300);fill-opacity:1;fill-rule:evenodd;stroke:#000030;stroke-width:0.5;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
/><path
- d="M 248.88937,380.28407 C 260.52371,392.19325 279.48677,404.28563
279.48677,404.28563 L 283.24273,399.52196 C 270.37465,392.79686
252.46212,375.70363 252.46212,375.70363 L 248.88937,380.28407 z"
- id="path2430"
-
style="fill:url(#radialGradient3210);fill-opacity:1;fill-rule:evenodd;stroke:#606060;stroke-width:0.5;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
/><path
- d="M 349.52184,256.42873 C 370.04225,269.52883 386.16543,285.37718
386.16543,285.37718 L 388.91369,282.17086 C 377.9694,270.59048
352.22755,253.07064 352.22755,253.07064 L 349.52184,256.42873 z"
- id="path3236"
-
style="fill:url(#radialGradient3238);fill-opacity:1;fill-rule:evenodd;stroke:#606060;stroke-width:0.5;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
/><path
- d="M 462.24667,151.81129 C 473.05653,152.72737 474.88872,162.25471
474.88872,162.25471 C 425.60308,213.55574 353.41521,288.12545
353.41521,288.12545 L 349.75085,285.01074 C 413.32748,208.79208
462.24667,151.81129 462.24667,151.81129"
- id="path3240"
-
style="fill:url(#radialGradient3248);fill-opacity:1;fill-rule:evenodd;stroke:#4a4a4a;stroke-width:0.60000002;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
/></svg>
+--><!-- Created with Inkscape (http://www.inkscape.org/) --><defs
+ id="defs4770"><linearGradient
+ id="linearGradient4292"><stop
+ id="stop4294"
+ offset="0"
+ style="stop-color:#411f5d;stop-opacity:1" /><stop
+ id="stop4296"
+ offset="1"
+ style="stop-color:#5b2a85;stop-opacity:1"
/></linearGradient><linearGradient
+ id="linearGradient4284"><stop
+ offset="0"
+ style="stop-color:#8381c5;stop-opacity:1"
+ id="stop4286" /><stop
+ id="stop4290"
+ style="stop-color:#7e55b3;stop-opacity:0.99607843"
+ offset="0.56639391" /><stop
+ offset="1"
+ style="stop-color:#a52ecb;stop-opacity:0.99215686"
+ id="stop4288" /></linearGradient><linearGradient
+ id="linearGradient4898"><stop
+ id="stop4278"
+ style="stop-color:#bab8db;stop-opacity:1"
+ offset="0" /><stop
+ id="stop4280"
+ style="stop-color:#5955a9;stop-opacity:0.99159664"
+ offset="1" /></linearGradient><linearGradient
+ id="linearGradient3294"><stop
+ offset="0"
+ style="stop-color:#6376e6;stop-opacity:1"
+ id="stop3296" /><stop
+ offset="0.50094414"
+ style="stop-color:#222989;stop-opacity:1"
+ id="stop3302" /><stop
+ offset="1"
+ style="stop-color:#00003d;stop-opacity:1"
+ id="stop3298" /></linearGradient><linearGradient
+ id="linearGradient3284"><stop
+ offset="0"
+ style="stop-color:#000000;stop-opacity:1"
+ id="stop3286" /><stop
+ offset="0.84845906"
+ style="stop-color:#000000;stop-opacity:0.49803922"
+ id="stop3292" /><stop
+ offset="1"
+ style="stop-color:#000000;stop-opacity:0"
+ id="stop3288" /></linearGradient><linearGradient
+ id="linearGradient3274"><stop
+ offset="0"
+ style="stop-color:#000000;stop-opacity:1"
+ id="stop3276" /><stop
+ offset="1"
+ style="stop-color:#000000;stop-opacity:0"
+ id="stop3278" /></linearGradient><linearGradient
+ id="linearGradient3262"><stop
+ offset="0"
+ style="stop-color:#000000;stop-opacity:1"
+ id="stop3264" /><stop
+ offset="1"
+ style="stop-color:#000000;stop-opacity:0"
+ id="stop3266" /></linearGradient><linearGradient
+ id="linearGradient3242"><stop
+ offset="0"
+ style="stop-color:#282828;stop-opacity:1"
+ id="stop3244" /><stop
+ offset="0.39253417"
+ style="stop-color:#808080;stop-opacity:1"
+ id="stop3252" /><stop
+ offset="1"
+ style="stop-color:#d9d9d9;stop-opacity:1"
+ id="stop3246" /></linearGradient><linearGradient
+ id="linearGradient3202"><stop
+ offset="0"
+ style="stop-color:#2b2b2b;stop-opacity:1"
+ id="stop3204" /><stop
+ offset="0.5"
+ style="stop-color:#828383;stop-opacity:1"
+ id="stop3250" /><stop
+ offset="1"
+ style="stop-color:#dadbdb;stop-opacity:1"
+ id="stop3206" /></linearGradient><linearGradient
+ id="linearGradient4966"><stop
+ offset="0"
+ style="stop-color:#b6b3d8;stop-opacity:1"
+ id="stop4968" /><stop
+ offset="1"
+ style="stop-color:#b6b3d8;stop-opacity:0"
+ id="stop4970" /></linearGradient><linearGradient
+ id="linearGradient4938"><stop
+ offset="0"
+ style="stop-color:#000000;stop-opacity:1"
+ id="stop4940" /><stop
+ offset="1"
+ style="stop-color:#000000;stop-opacity:0"
+ id="stop4942" /></linearGradient><linearGradient
+ id="linearGradient4282"><stop
+ offset="0"
+ style="stop-color:#bab8db;stop-opacity:1"
+ id="stop4900" /><stop
+ offset="1"
+ style="stop-color:#5955a9;stop-opacity:0.99159664"
+ id="stop4902" /></linearGradient><linearGradient
+ id="linearGradient4876"><stop
+ offset="0"
+ style="stop-color:#d3d2e8;stop-opacity:1"
+ id="stop4878" /><stop
+ offset="1"
+ style="stop-color:#5955a9;stop-opacity:0.99159664"
+ id="stop4880" /></linearGradient><radialGradient
+
gradientTransform="matrix(0.6817439,0,0,0.5905355,-3.8523706,-28.935273)"
+ gradientUnits="userSpaceOnUse"
+ xlink:href="#linearGradient4898"
+ id="radialGradient4892"
+ fy="-108.96888"
+ fx="20.951529"
+ r="266.76535"
+ cy="-108.96888"
+ cx="20.951529" /><radialGradient
+ gradientTransform="matrix(1,0,0,0.1854103,0,383.88493)"
+ gradientUnits="userSpaceOnUse"
+ xlink:href="#linearGradient4938"
+ id="radialGradient4944"
+ fy="471.26172"
+ fx="233.8876"
+ r="170.49393"
+ cy="471.26172"
+ cx="233.8876" /><radialGradient
+ gradientTransform="matrix(1,0,0,0.9121621,0,32.654948)"
+ gradientUnits="userSpaceOnUse"
+ xlink:href="#linearGradient4966"
+ id="radialGradient4972"
+ fy="371.76376"
+ fx="299.70135"
+ r="76.696358"
+ cy="371.76376"
+ cx="299.70135" /><radialGradient
+
gradientTransform="matrix(0.414705,0.3300575,-0.5059004,0.6356454,346.95314,49.479585)"
+ gradientUnits="userSpaceOnUse"
+ xlink:href="#linearGradient3202"
+ id="radialGradient3210"
+ fy="390.45248"
+ fx="289.44067"
+ r="17.67668"
+ cy="390.45248"
+ cx="289.44067" /><radialGradient
+
gradientTransform="matrix(0.414705,0.3300575,-0.5059004,0.6356454,448.41009,-65.398074)"
+ gradientUnits="userSpaceOnUse"
+ xlink:href="#linearGradient3202"
+ id="radialGradient3238"
+ fy="382.14804"
+ fx="283.50717"
+ r="17.67668"
+ cy="382.14804"
+ cx="283.50717" /><radialGradient
+
gradientTransform="matrix(-6.5565014e-2,-5.9721765e-2,1.6871024,-1.8521705,171.90774,540.51473)"
+ gradientUnits="userSpaceOnUse"
+ xlink:href="#linearGradient3242"
+ id="radialGradient3248"
+ fy="181.18982"
+ fx="418.45551"
+ r="63.068935"
+ cy="181.18982"
+ cx="418.45551" /><radialGradient
+
gradientTransform="matrix(0.4055116,-3.3440123e-2,0.1034174,4.3988695,177.23251,-1191.6649)"
+ gradientUnits="userSpaceOnUse"
+ xlink:href="#linearGradient3262"
+ id="radialGradient3268"
+ fy="357.33591"
+ fx="354.51709"
+ r="33.712105"
+ cy="357.33591"
+ cx="354.51709" /><radialGradient
+
gradientTransform="matrix(-0.1339874,-0.1146812,0.3079048,-0.3597394,444.23592,395.03849)"
+ gradientUnits="userSpaceOnUse"
+ xlink:href="#linearGradient3274"
+ id="radialGradient3280"
+ fy="223.55537"
+ fx="510.58469"
+ r="132.28336"
+ cy="223.55537"
+ cx="510.58469" /><radialGradient
+
gradientTransform="matrix(-1.2497569,1.3798305,-9.6289463e-2,-7.2974479e-2,674.3826,-70.590682)"
+ gradientUnits="userSpaceOnUse"
+ xlink:href="#linearGradient3284"
+ id="radialGradient3290"
+ fy="-158.17821"
+ fx="284.4671"
+ r="110.2972"
+ cy="-158.17821"
+ cx="284.4671" /><radialGradient
+
gradientTransform="matrix(-0.1008165,-8.0872321e-2,1.0745309,-1.3395252,13.843287,784.79288)"
+ gradientUnits="userSpaceOnUse"
+ xlink:href="#linearGradient3294"
+ id="radialGradient3300"
+ fy="356.62274"
+ fx="425.51019"
+ r="143.34167"
+ cy="356.62274"
+ cx="425.51019" /><filter
+ height="1.088351"
+ y="-0.044175496"
+ width="1.0892536"
+ x="-0.044626798"
+ id="filter4350"
+ style="color-interpolation-filters:sRGB"><feGaussianBlur
+ id="feGaussianBlur4352"
+ stdDeviation="8.7848425" /></filter><linearGradient
+ y2="300.73987"
+ x2="236.61363"
+ y1="-161.8512"
+ x1="-122.20192"
+ spreadMethod="pad"
+
gradientTransform="matrix(0.87385837,0,0,0.82818057,246.00762,250.28138)"
+ gradientUnits="userSpaceOnUse"
+ id="linearGradient4245"
+ xlink:href="#linearGradient4284" /><linearGradient
+ y2="66.018341"
+ x2="173.94518"
+ y1="396.6066"
+ x1="447.80933"
+
gradientTransform="matrix(0.98684959,0,0,0.98684959,3.0344187,2.5250397)"
+ gradientUnits="userSpaceOnUse"
+ id="linearGradient4247"
+ xlink:href="#linearGradient4292" /></defs><rect
+ style="fill:none;display:none"
+ id="rect4772"
+ y="0.20100001"
+ x="0.171"
+ height="512"
+ width="512" /><g
+ style="display:none"
+ id="g4788"><g
+ style="display:inline"
+ id="g4790" /></g><g
+ style="display:none"
+ id="g4806"><g
+ style="display:inline"
+ id="g4808"><path
+ style="fill:#050505;display:none"
+ id="path4810"
+ d="M 349.098,256.651 C 348.833,256.397 386.735,284.256
388.519,281.663 C 394.881,272.411 470.565,188.526 473.303,165.427 C
473.545,163.424 472.787,161.331 472.787,161.331 C 472.787,161.331
471.597,161.187 466.462,157.017 C 463.77,154.825 460.979,152.436
460.979,152.436 C 444.925,153.434 403.094,193.995 349.917,256.004"
/></g></g><path
+
style="opacity:0.40500004;fill:#211f46;fill-opacity:0.99607843;stroke:#0a0b1b;stroke-width:8.53333378;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1;filter:url(#filter4350)"
+ id="path4233"
+ d="m 491.66937,257.75916 c 0,131.79436 -105.76,238.63481
-236.22155,238.63481 -130.46155,0 -236.221539,-106.84045 -236.221539,-238.63481
0,-131.79437 105.759989,-238.634808 236.221539,-238.634808 130.46155,0
236.22155,106.840438 236.22155,238.634808 z"
+ transform="matrix(0.98684957,0,0,0.98684957,3.0344041,2.5250397)" /><path
+ d="m 488.23812,256.89456 c 0,130.06121 -104.3692,235.49665
-233.1151,235.49665 -128.7459,0 -233.115201,-105.43544 -233.115201,-235.49665
0,-130.06123 104.369301,-235.49666 233.115201,-235.49666 128.7459,0
233.1151,105.43543 233.1151,235.49666 z"
+ id="path4235"
+
style="opacity:1;fill:url(#linearGradient4245);fill-opacity:1;stroke:url(#linearGradient4247);stroke-width:13.33816814;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
/><path
+ d="m 175.0003,422.31057 c 0,0 19.7385,1.39634 45.1312,-0.84159
10.2834,-0.9063 49.3267,-4.74128 78.5169,-11.14289 0,0 35.5899,-7.61669
54.6301,-14.63335 19.9225,-7.34185 30.7636,-13.57304 35.6433,-22.40243
-0.2128,-1.80907 1.5024,-8.22438 -7.685,-12.07788 -23.4887,-9.85199
-50.73,-8.06998 -104.6338,-9.21285 -59.7772,-2.05391 -79.6627,-12.05971
-90.2556,-20.11838 -10.1579,-8.17519 -5.05,-30.79254 38.4742,-50.71499
21.9244,-10.60898 107.8705,-30.18698 107.8705,-30.18698 -28.9451,-14.3 [...]
+ id="path4237"
+
style="fill:#ffffff;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
/></svg>
diff --git a/etc/images/icons/hicolor/scalable/apps/emacs.svg
b/etc/images/icons/hicolor/scalable/apps/emacs23.svg
similarity index 100%
copy from etc/images/icons/hicolor/scalable/apps/emacs.svg
copy to etc/images/icons/hicolor/scalable/apps/emacs23.svg
diff --git a/etc/images/icons/hicolor/scalable/mimetypes/emacs-document.svg
b/etc/images/icons/hicolor/scalable/mimetypes/emacs-document.svg
index 120abda..fde79a2 100644
--- a/etc/images/icons/hicolor/scalable/mimetypes/emacs-document.svg
+++ b/etc/images/icons/hicolor/scalable/mimetypes/emacs-document.svg
@@ -1,216 +1,247 @@
<?xml version="1.0" encoding="UTF-8" standalone="no"?>
-<!-- Gnu Emacs Document Icon
-
- Copyright (C) 2008-2015 Free Software Foundation, Inc.
-
- This file is part of GNU Emacs.
-
- GNU Emacs is free software: you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 3 of the License, or
- (at your option) any later version.
-
- GNU Emacs is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
-
- You should have received a copy of the GNU General Public License
- along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
--->
-<!-- Created with Inkscape (http://www.inkscape.org/) -->
<svg
+ xmlns:dc="http://purl.org/dc/elements/1.1/";
+ xmlns:cc="http://creativecommons.org/ns#";
+ xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#";
xmlns:svg="http://www.w3.org/2000/svg";
xmlns="http://www.w3.org/2000/svg";
xmlns:xlink="http://www.w3.org/1999/xlink";
- xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape";
- version="1.0"
- width="512"
- height="512"
- viewBox="0.5 25.1 512 512"
+ xml:space="preserve"
id="svg2478"
- xml:space="preserve">
-<defs
- id="defs2480"><linearGradient
- id="linearGradient3251"><stop
- id="stop3253"
- style="stop-color:#000000;stop-opacity:1"
- offset="0" /><stop
- id="stop3255"
- style="stop-color:#000000;stop-opacity:0"
- offset="1" /></linearGradient><linearGradient
- id="linearGradient3591"><stop
- id="stop3593"
- style="stop-color:#ffffff;stop-opacity:1"
- offset="0" /><stop
- id="stop3595"
- style="stop-color:#969696;stop-opacity:1"
- offset="1" /></linearGradient><linearGradient
- id="linearGradient3423"><stop
- id="stop3425"
- style="stop-color:#e7e7e8;stop-opacity:1"
- offset="0" /><stop
- id="stop3427"
- style="stop-color:#ffffff;stop-opacity:1"
- offset="1" /></linearGradient><linearGradient
- id="linearGradient3411"><stop
- id="stop3413"
- style="stop-color:#000000;stop-opacity:1"
- offset="0" /><stop
- id="stop3415"
- style="stop-color:#000000;stop-opacity:0"
- offset="1" /></linearGradient><linearGradient
- id="linearGradient3399"><stop
- id="stop3401"
- style="stop-color:#000000;stop-opacity:0.23529412"
- offset="0" /><stop
- id="stop3403"
- style="stop-color:#969696;stop-opacity:0"
- offset="1" /></linearGradient><linearGradient
- id="linearGradient3385"><stop
- id="stop3387"
- style="stop-color:#000000;stop-opacity:1"
- offset="0" /><stop
- id="stop3389"
- style="stop-color:#000000;stop-opacity:0"
- offset="1" /></linearGradient><linearGradient
- id="linearGradient4966"><stop
- id="stop4968"
- style="stop-color:#9d99cb;stop-opacity:1"
- offset="0" /><stop
- id="stop4970"
- style="stop-color:#b6b3d8;stop-opacity:0"
- offset="1" /></linearGradient><radialGradient
- cx="299.70135"
- cy="371.76376"
- r="76.696358"
- fx="299.70135"
- fy="371.76376"
- id="radialGradient4972"
- xlink:href="#linearGradient4966"
- gradientUnits="userSpaceOnUse"
- gradientTransform="matrix(0.6567567,0,0,0.4104729,184.64364,308.30559)"
/><linearGradient
- id="linearGradient4898"><stop
- id="stop4900"
- style="stop-color:#9693c8;stop-opacity:1"
- offset="0" /><stop
- id="stop4902"
- style="stop-color:#5955a9;stop-opacity:0.99159664"
- offset="1" /></linearGradient><radialGradient
- cx="20.951529"
- cy="-108.96888"
- r="266.76535"
- fx="20.951529"
- fy="-108.96888"
- id="radialGradient4892"
- xlink:href="#linearGradient4898"
- gradientUnits="userSpaceOnUse"
- gradientTransform="matrix(0.2716588,0,0,0.2230142,373.70305,393.43878)" />
-<linearGradient
- x1="80.842102"
- y1="140.17206"
- x2="198.41295"
- y2="71.767204"
- id="linearGradient3391"
- xlink:href="#linearGradient3385"
- gradientUnits="userSpaceOnUse" /><radialGradient
- cx="91.433197"
- cy="186.271"
- r="136"
- fx="91.433197"
- fy="186.271"
- id="radialGradient3393"
- xlink:href="#linearGradient3385"
- gradientUnits="userSpaceOnUse"
- gradientTransform="matrix(1,0,0,1.0992647,0,-14.840074)" /><linearGradient
- x1="80.5"
- y1="506"
- x2="229.86604"
- y2="357.5979"
- id="linearGradient3405"
- xlink:href="#linearGradient3399"
- gradientUnits="userSpaceOnUse"
- gradientTransform="translate(-0.2692978,0.2692938)" /><linearGradient
- x1="262.18225"
- y1="86.313828"
- x2="258.51788"
- y2="495.98917"
- id="linearGradient3429"
- xlink:href="#linearGradient3423"
- gradientUnits="userSpaceOnUse" /><filter
- id="filter3567"><feGaussianBlur
- id="feGaussianBlur3569"
- stdDeviation="4.2737072"
- inkscape:collect="always" /></filter><linearGradient
- x1="368.36868"
- y1="115.66505"
- x2="389.52469"
- y2="95.825417"
- id="linearGradient3597"
- xlink:href="#linearGradient3591"
- gradientUnits="userSpaceOnUse" /><filter
- height="1.768"
- y="-0.384"
- width="1.768"
- x="-0.384"
- id="filter3715"><feGaussianBlur
- id="feGaussianBlur3717"
- stdDeviation="14.421378"
- inkscape:collect="always" /></filter><filter
- id="filter3731"><feGaussianBlur
- id="feGaussianBlur3733"
- stdDeviation="4.397419"
- inkscape:collect="always" /></filter><linearGradient
- x1="348.03799"
- y1="139.48338"
- x2="394.19592"
- y2="83.418686"
- id="linearGradient3257"
- xlink:href="#linearGradient3251"
- gradientUnits="userSpaceOnUse" /></defs>
-<path
- d="M 65.840457,40.220841 L 65.840457,531.21586 L 454.73556,531.21586 C
454.73556,531.21586 454.82343,271.39779 454.73556,195.85859 C
454.7129,176.38596 452.52523,165.22182 440.52509,152.46728 C
385.21346,93.678448 362.19141,71.631941 340.14323,51.220087 C
333.95591,45.491962 327.07219,40.426681 305.47897,40.220841 C
275.14906,39.931738 168.81642,40.028182 65.840457,40.220841 z"
- transform="matrix(0.9551184,0,0,0.9693433,12.274847,2.7155996)"
- id="path3431"
-
style="fill:#0a0a0a;fill-opacity:0.39215686;fill-rule:evenodd;stroke:#000000;stroke-width:0.42872402;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1;filter:url(#filter3731)"
/><rect
- width="512"
+ viewBox="0.5 25.1 512 512"
height="512"
- x="0.5"
- y="25.1"
- id="rect2482"
- style="fill:none;stroke:#000000;stroke-width:1.06089997;display:none"
/><path
- d="M 505.48196,424.97062 C 505.48196,484.27809 457.88996,532.35629
399.18226,532.35629 C 340.47457,532.35629 292.88257,484.27809
292.88257,424.97062 C 292.88257,365.66316 340.47457,317.58496
399.18226,317.58496 C 457.88996,317.58496 505.48196,365.66316
505.48196,424.97062 z"
- transform="matrix(0.9609994,0,0,0.9613938,11.422588,12.260738)"
- id="path3503"
-
style="opacity:1;fill:#646464;fill-opacity:0.39215686;stroke:#7b0000;stroke-width:0;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1;filter:url(#filter3567)"
/>
-
-
-
-
-
-<path
- d="M 80.5,39.1 L 80.5,506 L 436.5,506 C 436.5,506 436.94688,264.06231
436.86644,192.2301 C 436.8457,173.71308 433.76569,159.25553 422.20901,147.67024
C 365.34657,90.667114 353.06631,78.680195 332.88312,59.270019 C
327.21916,53.82299 317.43656,40.028603 299.86845,39.1 C 272.10272,39.049948
174.76564,38.916782 80.5,39.1 z"
- id="path3419"
-
style="fill:url(#linearGradient3429);fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.40000001;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
/><rect
- width="264.62119"
- height="328.51199"
- x="80.5"
- y="177.48801"
- id="rect3395"
-
style="opacity:1;fill:url(#linearGradient3405);fill-opacity:1;stroke:#000030;stroke-width:0;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
/><path
- d="M 485.69442,407.3817 C 485.69442,466.68917 438.10242,514.76737
379.39472,514.76737 C 320.68703,514.76737 273.09503,466.68917
273.09503,407.3817 C 273.09503,348.07424 320.68703,299.99604
379.39472,299.99604 C 438.10242,299.99604 485.69442,348.07424
485.69442,407.3817 z"
- id="path4864"
-
style="opacity:1;fill:url(#radialGradient4892);fill-opacity:1;stroke:#000000;stroke-width:0.40000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
/><path
- d="M 431.84539,460.90456 C 431.85316,478.2949 409.29909,492.39514
381.47453,492.39514 C 353.64998,492.39514 331.0959,478.2949 331.10368,460.90456
C 331.0959,443.51421 353.64998,429.41397 381.47453,429.41397 C
409.29909,429.41397 431.85316,443.51421 431.84539,460.90456 L
431.84539,460.90456 z"
- id="path4946"
-
style="opacity:1;fill:url(#radialGradient4972);fill-opacity:1;stroke:#7b0000;stroke-width:0;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
/><path
- d="M 322.56719,477.69483 C 322.56719,477.69483 332.02069,480.43979
344.60443,482.009 C 349.70053,482.6445 369.09026,484.86568 383.95666,484.80739
C 383.95666,484.80739 402.06264,484.82793 412.05706,483.40819 C
422.5146,481.92266 428.43925,480.02681 431.73651,476.24343 C
431.82239,475.34134 433.32798,472.40082 429.26306,469.56513 C
418.87065,462.31538 405.43557,460.33094 379.33956,454.13351 C
350.48241,446.8783 341.85848,439.93084 337.55017,434.90293 C 333.4656,429.86387
338.31689,419. [...]
- id="path4839"
-
style="fill:#ffffff;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
/><path
- d="M 343.70805,92.437911 L 340.45142,163.9826 L 407.92401,146.89664 L
343.70805,92.437911 z"
- id="path3605"
-
style="fill:#464646;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;filter:url(#filter3715)"
/><path
- d="M 345.72328,141.21214 C 369.54719,142.1578 408.63612,148.57658
423.38894,158.82173 C 429.63156,163.15694 437.02426,166.82736
436.86644,192.2301 C 436.05863,170.15935 433.76569,159.25553
422.20901,147.67024 C 365.34657,90.667114 353.06631,78.680195
332.88312,59.270019 C 316.59252,41.730605 308.6525,39.564301 299.86845,39.1 C
326.8119,41.20075 339.80786,67.674693 345.72328,141.21214 z"
- id="path3587"
-
style="fill:url(#linearGradient3597);fill-opacity:1;fill-rule:evenodd;stroke:url(#linearGradient3257);stroke-width:0.40000001;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
/></svg>
+ width="512"
+ version="1.0"><metadata
+ id="metadata4776"><rdf:RDF><cc:Work
+ rdf:about=""><dc:format>image/svg+xml</dc:format><dc:type
+ rdf:resource="http://purl.org/dc/dcmitype/StillImage";
/><dc:title></dc:title></cc:Work></rdf:RDF></metadata><defs
+ id="defs2480"><linearGradient
+ id="linearGradient3251"><stop
+ offset="0"
+ style="stop-color:#000000;stop-opacity:1"
+ id="stop3253" /><stop
+ offset="1"
+ style="stop-color:#000000;stop-opacity:0"
+ id="stop3255" /></linearGradient><linearGradient
+ id="linearGradient3591"><stop
+ offset="0"
+ style="stop-color:#ffffff;stop-opacity:1"
+ id="stop3593" /><stop
+ offset="1"
+ style="stop-color:#969696;stop-opacity:1"
+ id="stop3595" /></linearGradient><linearGradient
+ id="linearGradient3423"><stop
+ offset="0"
+ style="stop-color:#e7e7e8;stop-opacity:1"
+ id="stop3425" /><stop
+ offset="1"
+ style="stop-color:#ffffff;stop-opacity:1"
+ id="stop3427" /></linearGradient><linearGradient
+ id="linearGradient3411"><stop
+ offset="0"
+ style="stop-color:#000000;stop-opacity:1"
+ id="stop3413" /><stop
+ offset="1"
+ style="stop-color:#000000;stop-opacity:0"
+ id="stop3415" /></linearGradient><linearGradient
+ id="linearGradient3399"><stop
+ offset="0"
+ style="stop-color:#000000;stop-opacity:0.23529412"
+ id="stop3401" /><stop
+ offset="1"
+ style="stop-color:#969696;stop-opacity:0"
+ id="stop3403" /></linearGradient><linearGradient
+ id="linearGradient3385"><stop
+ offset="0"
+ style="stop-color:#000000;stop-opacity:1"
+ id="stop3387" /><stop
+ offset="1"
+ style="stop-color:#000000;stop-opacity:0"
+ id="stop3389" /></linearGradient><linearGradient
+ id="linearGradient4966"><stop
+ offset="0"
+ style="stop-color:#9d99cb;stop-opacity:1"
+ id="stop4968" /><stop
+ offset="1"
+ style="stop-color:#b6b3d8;stop-opacity:0"
+ id="stop4970" /></linearGradient><radialGradient
+ gradientTransform="matrix(0.6567567,0,0,0.4104729,184.64364,308.30559)"
+ gradientUnits="userSpaceOnUse"
+ xlink:href="#linearGradient4966"
+ id="radialGradient4972"
+ fy="371.76376"
+ fx="299.70135"
+ r="76.696358"
+ cy="371.76376"
+ cx="299.70135" /><linearGradient
+ id="linearGradient4898"><stop
+ offset="0"
+ style="stop-color:#9693c8;stop-opacity:1"
+ id="stop4900" /><stop
+ offset="1"
+ style="stop-color:#5955a9;stop-opacity:0.99159664"
+ id="stop4902" /></linearGradient><radialGradient
+ gradientTransform="matrix(0.2716588,0,0,0.2230142,373.70305,393.43878)"
+ gradientUnits="userSpaceOnUse"
+ xlink:href="#linearGradient4898"
+ id="radialGradient4892"
+ fy="-108.96888"
+ fx="20.951529"
+ r="266.76535"
+ cy="-108.96888"
+ cx="20.951529" /><linearGradient
+ gradientUnits="userSpaceOnUse"
+ xlink:href="#linearGradient3385"
+ id="linearGradient3391"
+ y2="71.767204"
+ x2="198.41295"
+ y1="140.17206"
+ x1="80.842102" /><radialGradient
+ gradientTransform="matrix(1,0,0,1.0992647,0,-14.840074)"
+ gradientUnits="userSpaceOnUse"
+ xlink:href="#linearGradient3385"
+ id="radialGradient3393"
+ fy="186.271"
+ fx="91.433197"
+ r="136"
+ cy="186.271"
+ cx="91.433197" /><linearGradient
+ gradientTransform="translate(-0.2692978,0.2692938)"
+ gradientUnits="userSpaceOnUse"
+ xlink:href="#linearGradient3399"
+ id="linearGradient3405"
+ y2="357.5979"
+ x2="229.86604"
+ y1="506"
+ x1="80.5" /><linearGradient
+ gradientUnits="userSpaceOnUse"
+ xlink:href="#linearGradient3423"
+ id="linearGradient3429"
+ y2="495.98917"
+ x2="258.51788"
+ y1="86.313828"
+ x1="262.18225" /><filter
+ id="filter3567"><feGaussianBlur
+ stdDeviation="4.2737072"
+ id="feGaussianBlur3569" /></filter><linearGradient
+ gradientUnits="userSpaceOnUse"
+ xlink:href="#linearGradient3591"
+ id="linearGradient3597"
+ y2="95.825417"
+ x2="389.52469"
+ y1="115.66505"
+ x1="368.36868" /><filter
+ id="filter3715"
+ x="-0.384"
+ width="1.768"
+ y="-0.384"
+ height="1.768"><feGaussianBlur
+ stdDeviation="14.421378"
+ id="feGaussianBlur3717" /></filter><filter
+ id="filter3731"><feGaussianBlur
+ stdDeviation="4.397419"
+ id="feGaussianBlur3733" /></filter><linearGradient
+ gradientUnits="userSpaceOnUse"
+ xlink:href="#linearGradient3251"
+ id="linearGradient3257"
+ y2="83.418686"
+ x2="394.19592"
+ y1="139.48338"
+ x1="348.03799" /><filter
+ height="1.088351"
+ y="-0.044175494"
+ width="1.0892535"
+ x="-0.044626798"
+ id="filter4350"
+ style="color-interpolation-filters:sRGB"><feGaussianBlur
+ id="feGaussianBlur4352"
+ stdDeviation="8.7848425" /></filter><linearGradient
+
gradientTransform="matrix(0.38803836,0,0,0.36775507,375.02857,404.82819)"
+ spreadMethod="pad"
+ gradientUnits="userSpaceOnUse"
+ y2="300.73987"
+ x2="236.61363"
+ y1="-161.8512"
+ x1="-122.20192"
+ id="linearGradient4274"
+ xlink:href="#linearGradient4284" /><linearGradient
+ id="linearGradient4284"><stop
+ offset="0"
+ style="stop-color:#8381c5;stop-opacity:1"
+ id="stop4286" /><stop
+ id="stop4290"
+ style="stop-color:#7e55b3;stop-opacity:0.99607843"
+ offset="0.56639391" /><stop
+ offset="1"
+ style="stop-color:#a52ecb;stop-opacity:0.99215686"
+ id="stop4288" /></linearGradient><linearGradient
+
gradientTransform="matrix(0.43821233,0,0,0.43821233,267.13587,294.81153)"
+ gradientUnits="userSpaceOnUse"
+ y2="66.018341"
+ x2="173.94518"
+ y1="396.6066"
+ x1="447.80933"
+ id="linearGradient4298"
+ xlink:href="#linearGradient4292" /><linearGradient
+ id="linearGradient4292"><stop
+ id="stop4294"
+ offset="0"
+ style="stop-color:#411f5d;stop-opacity:1" /><stop
+ id="stop4296"
+ offset="1"
+ style="stop-color:#5b2a85;stop-opacity:1" /></linearGradient><filter
+ id="filter4354"
+ style="color-interpolation-filters:sRGB"><feGaussianBlur
+ id="feGaussianBlur4356"
+ stdDeviation="8.7848425" /></filter><filter
+ id="filter4358"
+ style="color-interpolation-filters:sRGB"><feGaussianBlur
+ id="feGaussianBlur4360"
+ stdDeviation="8.7848425" /></filter></defs><path
+
style="fill:#0a0a0a;fill-opacity:0.39215686;fill-rule:evenodd;stroke:#000000;stroke-width:0.42872402;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1;filter:url(#filter3731)"
+ id="path3431"
+ transform="matrix(0.9551184,0,0,0.9693433,12.274847,2.7155996)"
+ d="M 65.840457,40.220841 L 65.840457,531.21586 L 454.73556,531.21586 C
454.73556,531.21586 454.82343,271.39779 454.73556,195.85859 C
454.7129,176.38596 452.52523,165.22182 440.52509,152.46728 C
385.21346,93.678448 362.19141,71.631941 340.14323,51.220087 C
333.95591,45.491962 327.07219,40.426681 305.47897,40.220841 C
275.14906,39.931738 168.81642,40.028182 65.840457,40.220841 z" /><rect
+ style="fill:none;stroke:#000000;stroke-width:1.06089997;display:none"
+ id="rect2482"
+ y="25.1"
+ x="0.5"
+ height="512"
+ width="512" /><path
+
style="opacity:1;fill:#646464;fill-opacity:0.39215686;stroke:#7b0000;stroke-width:0;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1;filter:url(#filter3567)"
+ id="path3503"
+ transform="matrix(0.9609994,0,0,0.9613938,11.422588,12.260738)"
+ d="M 505.48196,424.97062 C 505.48196,484.27809 457.88996,532.35629
399.18226,532.35629 C 340.47457,532.35629 292.88257,484.27809
292.88257,424.97062 C 292.88257,365.66316 340.47457,317.58496
399.18226,317.58496 C 457.88996,317.58496 505.48196,365.66316
505.48196,424.97062 z" /><path
+ transform="matrix(0.43821233,0,0,0.43821233,267.13588,294.81152)"
+ d="m 491.66937,257.75916 c 0,131.79436 -105.76,238.63481
-236.22155,238.63481 -130.46155,0 -236.221539,-106.84045 -236.221539,-238.63481
0,-131.79437 105.759989,-238.634808 236.221539,-238.634808 130.46155,0
236.22155,106.840438 236.22155,238.634808 z"
+ id="path4351"
+
style="opacity:0.40500004;fill:#211f46;fill-opacity:0.99607843;stroke:#0a0b1b;stroke-width:8.53333378;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1;filter:url(#filter4350)"
/><path
+
style="fill:url(#linearGradient3429);fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.40000001;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="path3419"
+ d="M 80.5,39.1 L 80.5,506 L 436.5,506 C 436.5,506 436.94688,264.06231
436.86644,192.2301 C 436.8457,173.71308 433.76569,159.25553 422.20901,147.67024
C 365.34657,90.667114 353.06631,78.680195 332.88312,59.270019 C
327.21916,53.82299 317.43656,40.028603 299.86845,39.1 C 272.10272,39.049948
174.76564,38.916782 80.5,39.1 z" /><path
+
style="opacity:1;fill:url(#linearGradient4274);fill-opacity:1;stroke:url(#linearGradient4298);stroke-width:5.92283726;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="path4864-6"
+ d="m 482.59147,407.7648 c 0,57.75387 -46.34532,104.5727
-103.51517,104.5727 -57.16986,0 -103.51523,-46.81883 -103.51523,-104.5727
0,-57.75392 46.34537,-104.57271 103.51523,-104.57271 57.16985,0
103.51517,46.81879 103.51517,104.57271 z" /><rect
+
style="opacity:1;fill:url(#linearGradient3405);fill-opacity:1;stroke:#000030;stroke-width:0;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect3395"
+ y="177.48801"
+ x="80.5"
+ height="328.51199"
+ width="264.62119" /><path
+
style="fill:#ffffff;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="path4839-2"
+ d="m 340.11943,481.55867 c 0,0 8.7649,0.62002 20.04059,-0.37371
4.56637,-0.40261 21.90362,-2.1054 34.86557,-4.94804 0,0 15.80375,-3.38218
24.25859,-6.49798 8.84665,-3.26012 13.66064,-6.02712 15.82747,-9.9478
-0.0942,-0.80332 0.66719,-3.65208 -3.41254,-5.36325 -10.43022,-4.37477
-22.52676,-3.58349 -46.46283,-4.09096 -26.54416,-0.91202 -35.37438,-5.35515
-40.0781,-8.93361 -4.51067,-3.63019 -2.24252,-13.67348 17.0845,-22.52008
9.73556,-4.71093 47.9001,-13.40459 47.9001,-13.40459 -12.85 [...]
+ transform="matrix(0.43821233,0,0,0.43821233,267.13588,294.81152)"
+ style="opacity:0.40500004;stroke:none;filter:url(#filter4354)"
+ id="g4796"><g
+ style="stroke:none"
+ id="g4800" /></g><g
+ transform="matrix(0.43821233,0,0,0.43821233,267.13588,294.81152)"
+ style="opacity:0.40500004;filter:url(#filter4358)"
+ id="g4774" /><path
+
style="fill:#464646;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;filter:url(#filter3715)"
+ id="path3605"
+ d="M 343.70805,92.437911 L 340.45142,163.9826 L 407.92401,146.89664 L
343.70805,92.437911 z" /><path
+
style="fill:url(#linearGradient3597);fill-opacity:1;fill-rule:evenodd;stroke:url(#linearGradient3257);stroke-width:0.40000001;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="path3587"
+ d="M 345.72328,141.21214 C 369.54719,142.1578 408.63612,148.57658
423.38894,158.82173 C 429.63156,163.15694 437.02426,166.82736
436.86644,192.2301 C 436.05863,170.15935 433.76569,159.25553
422.20901,147.67024 C 365.34657,90.667114 353.06631,78.680195
332.88312,59.270019 C 316.59252,41.730605 308.6525,39.564301 299.86845,39.1 C
326.8119,41.20075 339.80786,67.674693 345.72328,141.21214 z" /></svg>
\ No newline at end of file
diff --git a/etc/images/icons/hicolor/scalable/mimetypes/emacs-document.svg
b/etc/images/icons/hicolor/scalable/mimetypes/emacs-document23.svg
similarity index 100%
copy from etc/images/icons/hicolor/scalable/mimetypes/emacs-document.svg
copy to etc/images/icons/hicolor/scalable/mimetypes/emacs-document23.svg
diff --git a/lisp/autorevert.el b/lisp/autorevert.el
index 37ee8ee..18b8161 100644
--- a/lisp/autorevert.el
+++ b/lisp/autorevert.el
@@ -570,37 +570,54 @@ no more reverts are possible until the next call of
;; Since we watch a directory, a file name must be returned.
(cl-assert (stringp file))
(when (eq action 'renamed) (cl-assert (stringp file1)))
- ;; Loop over all buffers, in order to find the intended one.
- (cl-dolist (buffer buffers)
- (when (buffer-live-p buffer)
- (with-current-buffer buffer
- (when (or
- ;; A buffer associated with a file.
- (and (stringp buffer-file-name)
- (or
- (and (memq action '(attribute-changed changed created))
- (string-equal
- (file-name-nondirectory file)
- (file-name-nondirectory buffer-file-name)))
- (and (eq action 'renamed)
- (string-equal
- (file-name-nondirectory file1)
- (file-name-nondirectory buffer-file-name)))))
- ;; A buffer w/o a file, like dired.
- (and (null buffer-file-name)
- (memq action '(created renamed deleted))))
- ;; Mark buffer modified.
- (setq auto-revert-notify-modified-p t)
-
- ;; Revert the buffer now if we're not locked out.
- (when (/= auto-revert-buffers-counter-lockedout
- auto-revert-buffers-counter)
- (auto-revert-handler)
- (setq auto-revert-buffers-counter-lockedout
- auto-revert-buffers-counter))
-
- ;; No need to check other buffers.
- (cl-return))))))))
+
+ (if (eq action 'stopped)
+ ;; File notification has stopped. Continue with polling.
+ (cl-dolist (buffer buffers)
+ (with-current-buffer buffer
+ (when (or
+ ;; A buffer associated with a file.
+ (and (stringp buffer-file-name)
+ (string-equal
+ (file-name-nondirectory file)
+ (file-name-nondirectory buffer-file-name)))
+ ;; A buffer w/o a file, like dired.
+ (null buffer-file-name))
+ (auto-revert-notify-rm-watch)
+ (setq-local auto-revert-use-notify nil))))
+
+ ;; Loop over all buffers, in order to find the intended one.
+ (cl-dolist (buffer buffers)
+ (when (buffer-live-p buffer)
+ (with-current-buffer buffer
+ (when (or
+ ;; A buffer associated with a file.
+ (and (stringp buffer-file-name)
+ (or
+ (and (memq
+ action '(attribute-changed changed created))
+ (string-equal
+ (file-name-nondirectory file)
+ (file-name-nondirectory buffer-file-name)))
+ (and (eq action 'renamed)
+ (string-equal
+ (file-name-nondirectory file1)
+ (file-name-nondirectory buffer-file-name)))))
+ ;; A buffer w/o a file, like dired.
+ (and (null buffer-file-name)
+ (memq action '(created renamed deleted))))
+ ;; Mark buffer modified.
+ (setq auto-revert-notify-modified-p t)
+
+ ;; Revert the buffer now if we're not locked out.
+ (when (/= auto-revert-buffers-counter-lockedout
+ auto-revert-buffers-counter)
+ (auto-revert-handler)
+ (setq auto-revert-buffers-counter-lockedout
+ auto-revert-buffers-counter))
+
+ ;; No need to check other buffers.
+ (cl-return)))))))))
(defun auto-revert-active-p ()
"Check if auto-revert is active (in current buffer or globally)."
@@ -671,7 +688,7 @@ This is an internal function used by Auto-Revert Mode."
;; `preserve-modes' avoids changing the (minor) modes. But we do
;; want to reset the mode for VC, so we do it manually.
(when (or revert auto-revert-check-vc-info)
- (vc-find-file-hook))))
+ (vc-refresh-state))))
(defun auto-revert-tail-handler (size)
(let ((modified (buffer-modified-p))
diff --git a/lisp/cedet/cedet-global.el b/lisp/cedet/cedet-global.el
index 3773ba0..3ceed5d 100644
--- a/lisp/cedet/cedet-global.el
+++ b/lisp/cedet/cedet-global.el
@@ -97,7 +97,7 @@ SCOPE is the scope of the search, such as 'project or
'subdirs."
;; Check for warnings.
(with-current-buffer b
(goto-char (point-min))
- (when (re-search-forward "Error\\|Warning" nil t)
+ (when (re-search-forward "Error\\|Warning\\|invalid" nil t)
(error "Output:\n%S" (buffer-string))))
b))
@@ -186,12 +186,14 @@ If a database already exists, then just update it."
(let ((root (cedet-gnu-global-root dir)))
(if root (setq dir root))
(let ((default-directory dir))
- (cedet-gnu-global-gtags-call
- (when root
- '("-u");; Incremental update flag.
- ))
- )
- ))
+ (if root
+ ;; Incremental update. This can be either "gtags -i" or
+ ;; "global -u"; the gtags manpage says it's better to use
+ ;; "global -u".
+ (cedet-gnu-global-call (list "-u"))
+ (cedet-gnu-global-gtags-call nil)
+ )
+ )))
(provide 'cedet-global)
diff --git a/lisp/cedet/ede/generic.el b/lisp/cedet/ede/generic.el
index b865ff5..d3be545 100644
--- a/lisp/cedet/ede/generic.el
+++ b/lisp/cedet/ede/generic.el
@@ -303,7 +303,7 @@ CLASS is the EIEIO class that is used to track this
project. It should subclass
(ede-generic-new-autoloader "generic-cvs" "Generic CVS"
"CVS" 'ede-generic-vc-project)
(ede-generic-new-autoloader "generic-mtn" "Generic Monotone"
- "_MTN/options" 'ede-generic-vc-project)
+ "_MTN" 'ede-generic-vc-project)
;; Take advantage of existing 'projectile' based projects.
;; @TODO - if projectile supports compile commands etc, can we
diff --git a/lisp/character-fold.el b/lisp/character-fold.el
index 988a506..223a2cd 100644
--- a/lisp/character-fold.el
+++ b/lisp/character-fold.el
@@ -23,14 +23,6 @@
;;; Code:
-;;;###autoload
-(defvar character-fold-search nil
- "Non-nil if searches should fold similar characters.
-This means some characters will match entire groups of characters.
-For instance, \" will match all variants of double quotes, and
-the letter a will match all of its accented versions (and then
-some).")
-
(defconst character-fold-table
(eval-when-compile
(let* ((equiv (make-char-table 'character-fold-table))
@@ -109,22 +101,60 @@ some).")
equiv))
"Used for folding characters of the same group during search.")
+(defun character-fold--make-space-string (n)
+ "Return a string that matches N spaces."
+ (format "\\(?:%s\\|%s\\)"
+ (make-string n ?\s)
+ (apply #'concat
+ (make-list n (or (aref character-fold-table ?\s) " ")))))
+
;;;###autoload
-(defun character-fold-to-regexp (string &optional lax)
+(defun character-fold-to-regexp (string &optional _lax)
"Return a regexp matching anything that character-folds into STRING.
-If `character-fold-search' is nil, `regexp-quote' string.
-Otherwise, any character in STRING that has an entry in
+Any character in STRING that has an entry in
`character-fold-table' is replaced with that entry (which is a
-regexp) and other characters are `regexp-quote'd.
-If LAX is non-nil, any single whitespace character is allowed to
-match any number of times."
- (if character-fold-search
- (apply #'concat
- (mapcar (lambda (c) (if (and lax (memq c '(?\s ?\t ?\r ?\n)))
- "[
\t\n\r\xa0\x2002\x2d\x200a\x202f\x205f\x3000]+"
- (or (aref character-fold-table c)
- (regexp-quote (string c)))))
- string))
- (regexp-quote string)))
+regexp) and other characters are `regexp-quote'd."
+ (let* ((spaces 0)
+ (chars (mapcar #'identity string))
+ (out chars))
+ ;; When the user types a space, we want to match the table entry,
+ ;; but we also want the ?\s to be visible to `search-spaces-regexp'.
+ ;; See commit message for a longer description.
+ (while chars
+ (let ((c (car chars)))
+ (setcar chars
+ (cond
+ ((eq c ?\s)
+ (setq spaces (1+ spaces))
+ nil)
+ ((> spaces 0)
+ (prog1 (concat (character-fold--make-space-string spaces)
+ (or (aref character-fold-table c)
+ (regexp-quote (string c))))
+ (setq spaces 0)))
+ (t (or (aref character-fold-table c)
+ (regexp-quote (string c))))))
+ (setq chars (cdr chars))))
+ (concat (apply #'concat out)
+ (when (> spaces 0)
+ (character-fold--make-space-string spaces)))))
+
+
+;;; Commands provided for completeness.
+(defun character-fold-search-forward (string &optional bound noerror count)
+ "Search forward for a character-folded version of STRING.
+STRING is converted to a regexp with `character-fold-to-regexp',
+which is searched for with `re-search-forward'.
+BOUND NOERROR COUNT are passed to `re-search-forward'."
+ (interactive "sSearch: ")
+ (re-search-forward (character-fold-to-regexp string) bound noerror count))
+
+(defun character-fold-search-backward (string &optional bound noerror count)
+ "Search backward for a character-folded version of STRING.
+STRING is converted to a regexp with `character-fold-to-regexp',
+which is searched for with `re-search-backward'.
+BOUND NOERROR COUNT are passed to `re-search-backward'."
+ (interactive "sSearch: ")
+ (re-search-backward (character-fold-to-regexp string) bound noerror count))
;;; character-fold.el ends here
diff --git a/lisp/custom.el b/lisp/custom.el
index c5d0e65..afff867 100644
--- a/lisp/custom.el
+++ b/lisp/custom.el
@@ -155,15 +155,14 @@ set to nil, as the value is no longer rogue."
(unless (memq :group args)
(custom-add-to-group (custom-current-group) symbol 'custom-variable))
(while args
- (let ((arg (car args)))
- (setq args (cdr args))
- (unless (symbolp arg)
+ (let ((keyword (pop args)))
+ (unless (symbolp keyword)
(error "Junk in args %S" args))
- (let ((keyword arg)
- (value (car args)))
- (unless args
- (error "Keyword %s is missing an argument" keyword))
- (setq args (cdr args))
+ (unless args
+ (error "Keyword %s is missing an argument" keyword))
+ (let ((value (pop args)))
+ ;; Can't use `pcase' because it is loaded after `custom.el'
+ ;; during bootstrap. See `loadup.el'.
(cond ((eq keyword :initialize)
(setq initialize value))
((eq keyword :set)
diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el
index 46d40d2..9f11514 100644
--- a/lisp/dired-aux.el
+++ b/lisp/dired-aux.el
@@ -921,6 +921,8 @@ ARGS are command switches passed to PROGRAM.")
(defvar dired-compress-files-alist
'(("\\.tar\\.gz\\'" . "tar -c %i | gzip -c9 > %o")
+ ("\\.tar\\.bz2\\'" . "tar -c %i | bzip2 -c9 > %o")
+ ("\\.tar\\.xz\\'" . "tar -c %i | xz -c9 > %o")
("\\.zip\\'" . "zip %o -r --filesync %i"))
"Control the compression shell command for `dired-do-compress-to'.
diff --git a/lisp/dired.el b/lisp/dired.el
index 0fe2349..c3cad0c 100644
--- a/lisp/dired.el
+++ b/lisp/dired.el
@@ -3897,7 +3897,7 @@ Ask means pop up a menu for the user to select one of
copy, move or link."
;;; Start of automatically extracted autoloads.
-;;;### (autoloads nil "dired-aux" "dired-aux.el"
"ce82e4e2d385923def05089e8aedb519")
+;;;### (autoloads nil "dired-aux" "dired-aux.el"
"29842a53d6651f8f535ec8e02d20d7cc")
;;; Generated autoloads from dired-aux.el
(autoload 'dired-diff "dired-aux" "\
diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el
index 2eba021..21c1f1b 100644
--- a/lisp/emacs-lisp/ert.el
+++ b/lisp/emacs-lisp/ert.el
@@ -64,7 +64,7 @@
(require 'ewoc)
(require 'find-func)
(require 'help)
-
+(require 'pp)
;;; UI customization options.
@@ -1300,7 +1300,8 @@ EXPECTEDP specifies whether the result was expected."
(defun ert--pp-with-indentation-and-newline (object)
"Pretty-print OBJECT, indenting it to the current column of point.
Ensures a final newline is inserted."
- (let ((begin (point)))
+ (let ((begin (point))
+ (pp-escape-newlines nil))
(pp object (current-buffer))
(unless (bolp) (insert "\n"))
(save-excursion
diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el
index 8bf49b0..8983454 100644
--- a/lisp/emacs-lisp/macroexp.el
+++ b/lisp/emacs-lisp/macroexp.el
@@ -322,8 +322,9 @@ definitions to shadow the loaded ones for use in file
byte-compilation."
(if (cdr exps) `(progn ,@exps) (car exps)))
(defun macroexp-unprogn (exp)
- "Turn EXP into a list of expressions to execute in sequence."
- (if (eq (car-safe exp) 'progn) (cdr exp) (list exp)))
+ "Turn EXP into a list of expressions to execute in sequence.
+Never returns an empty list."
+ (if (eq (car-safe exp) 'progn) (or (cdr exp) '(nil)) (list exp)))
(defun macroexp-let* (bindings exp)
"Return an expression equivalent to `(let* ,bindings ,exp)."
@@ -333,22 +334,33 @@ definitions to shadow the loaded ones for use in file
byte-compilation."
(t `(let* ,bindings ,exp))))
(defun macroexp-if (test then else)
- "Return an expression equivalent to `(if ,test ,then ,else)."
+ "Return an expression equivalent to `(if ,TEST ,THEN ,ELSE)."
(cond
((eq (car-safe else) 'if)
- (if (equal test (nth 1 else))
- ;; Doing a test a second time: get rid of the redundancy.
- `(if ,test ,then ,@(nthcdr 3 else))
- `(cond (,test ,then)
- (,(nth 1 else) ,(nth 2 else))
- (t ,@(nthcdr 3 else)))))
+ (cond
+ ;; Drop this optimization: It's unsafe (it assumes that `test' is
+ ;; pure, or at least idempotent), and it's not used even a single
+ ;; time while compiling Emacs's sources.
+ ;;((equal test (nth 1 else))
+ ;; ;; Doing a test a second time: get rid of the redundancy.
+ ;; (message "macroexp-if: sharing 'test' %S" test)
+ ;; `(if ,test ,then ,@(nthcdr 3 else)))
+ ((equal then (nth 2 else))
+ ;; (message "macroexp-if: sharing 'then' %S" then)
+ `(if (or ,test ,(nth 1 else)) ,then ,@(nthcdr 3 else)))
+ ((equal (macroexp-unprogn then) (nthcdr 3 else))
+ ;; (message "macroexp-if: sharing 'then' with not %S" then)
+ `(if (or ,test (not ,(nth 1 else)))
+ ,then ,@(macroexp-unprogn (nth 2 else))))
+ (t
+ `(cond (,test ,@(macroexp-unprogn then))
+ (,(nth 1 else) ,@(macroexp-unprogn (nth 2 else)))
+ (t ,@(nthcdr 3 else))))))
((eq (car-safe else) 'cond)
- `(cond (,test ,then)
- ;; Doing a test a second time: get rid of the redundancy, as above.
- ,@(remove (assoc test else) (cdr else))))
+ `(cond (,test ,@(macroexp-unprogn then)) ,@(cdr else)))
;; Invert the test if that lets us reduce the depth of the tree.
((memq (car-safe then) '(if cond)) (macroexp-if `(not ,test) else then))
- (t `(if ,test ,then ,else))))
+ (t `(if ,test ,then ,@(macroexp-unprogn else)))))
(defmacro macroexp-let2 (test sym exp &rest body)
"Evaluate BODY with SYM bound to an expression for EXP's value.
diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el
index cc437e0..5ef51f1 100644
--- a/lisp/emacs-lisp/map.el
+++ b/lisp/emacs-lisp/map.el
@@ -45,12 +45,12 @@
(require 'seq)
(pcase-defmacro map (&rest args)
- "pcase pattern matching map elements.
+ "Build a `pcase' pattern matching map elements.
-Matches if the object is a map (list, hash-table or array), and
-each PATTERN matches the corresponding elements of the map.
+The `pcase' pattern will match each element of PATTERN against
+the corresponding elements of the map.
-Supernumerary elements of the map are ignored if fewer ARGS are
+Extra elements of the map are ignored if fewer ARGS are
given, and the match does not fail.
ARGS can be a list of the form (KEY PAT), in which case KEY in an
@@ -92,7 +92,7 @@ Return RESULT if non-nil or the result of evaluation of the
form."
(t (error "Unsupported map: %s" ,map-var)))))
(defun map-elt (map key &optional default)
- "Perform a lookup in MAP of KEY and return its associated value.
+ "Lookup KEY in MAP and return its associated value.
If KEY is not found, return DEFAULT which defaults to nil.
If MAP is a list, `eql' is used to lookup KEY.
@@ -122,7 +122,7 @@ MAP can be a list, hash-table or array."
default)))
(defmacro map-put (map key value)
- "In MAP, associate KEY with VALUE and return MAP.
+ "Associate KEY with VALUE in MAP and return MAP.
If KEY is already present in MAP, replace the associated value
with VALUE.
@@ -133,8 +133,9 @@ MAP can be a list, hash-table or array."
,map)))
(defmacro map-delete (map key)
- "In MAP, delete the key KEY if present and return MAP.
-If MAP is an array, store nil at the index KEY.
+ "Delete KEY from MAP and return MAP.
+No error is signaled if KEY is not a key of MAP. If MAP is an
+array, store nil at the index KEY.
MAP can be a list, hash-table or array."
(declare (debug t))
@@ -245,7 +246,7 @@ MAP can be a list, hash-table or array."
(arrayp map)))
(defun map-empty-p (map)
- "Return non-nil is MAP is empty.
+ "Return non-nil if MAP is empty.
MAP can be a list, hash-table or array."
(map--dispatch map
@@ -254,7 +255,7 @@ MAP can be a list, hash-table or array."
:hash-table (zerop (hash-table-count map))))
(defun map-contains-key (map key &optional testfn)
- "Return non-nil if MAP contain the key KEY, nil otherwise.
+ "Return non-nil if MAP contain KEY, nil otherwise.
Equality is defined by TESTFN if non-nil or by `equal' if nil.
MAP can be a list, hash-table or array."
@@ -284,7 +285,7 @@ MAP can be a list, hash-table or array."
t))
(defun map-merge (type &rest maps)
- "Merge into a map of type TYPE all the key/value pairs in the maps MAPS.
+ "Merge into a map of type TYPE all the key/value pairs in MAPS.
MAP can be a list, hash-table or array."
(let (result)
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el
index 2dbcdf6..2962da5 100644
--- a/lisp/emacs-lisp/package.el
+++ b/lisp/emacs-lisp/package.el
@@ -889,7 +889,8 @@ untar into a directory named DIR; otherwise, signal an
error."
" --- automatically extracted autoloads\n"
";;\n"
";;; Code:\n"
- "(add-to-list 'load-path (or (file-name-directory #$) (car
load-path)))\n"
+ ;; `load-path' should contain only directory names
+ "(add-to-list 'load-path (directory-file-name (or
(file-name-directory #$) (car load-path))))\n"
" \n;; Local Variables:\n"
";; version-control: never\n"
";; no-byte-compile: t\n"
diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el
index f5189c7..6826509 100644
--- a/lisp/emacs-lisp/seq.el
+++ b/lisp/emacs-lisp/seq.el
@@ -4,7 +4,7 @@
;; Author: Nicolas Petton <address@hidden>
;; Keywords: sequences
-;; Version: 2.1
+;; Version: 2.2
;; Package: seq
;; Maintainer: address@hidden
@@ -61,305 +61,325 @@
(defmacro seq-doseq (spec &rest body)
"Loop over a sequence.
-Similar to `dolist' but can be applied to lists, strings, and vectors.
+Evaluate BODY with VAR bound to each element of SEQUENCE, in turn.
-Evaluate BODY with VAR bound to each element of SEQ, in turn.
+Similar to `dolist' but can be applied to lists, strings, and vectors.
-\(fn (VAR SEQ) BODY...)"
+\(fn (VAR SEQUENCE) BODY...)"
(declare (indent 1) (debug ((symbolp form &optional form) body)))
`(seq-do (lambda (,(car spec))
,@body)
,(cadr spec)))
(pcase-defmacro seq (&rest patterns)
- "pcase pattern matching sequence elements.
+ "Build a `pcase' pattern that matches elements of SEQUENCE.
-Matches if the object is a sequence (list, string or vector), and
-each PATTERN matches the corresponding element of the sequence.
+The `pcase' pattern will match each element of PATTERNS against the
+corresponding element of SEQUENCE.
-Supernumerary elements of the sequence are ignored if fewer
-PATTERNS are given, and the match does not fail."
+Extra elements of the sequence are ignored if fewer PATTERNS are
+given, and the match does not fail."
`(and (pred seq-p)
,@(seq--make-pcase-bindings patterns)))
-(defmacro seq-let (args seq &rest body)
- "Bind the variables in ARGS to the elements of SEQ then evaluate BODY.
+(defmacro seq-let (args sequence &rest body)
+ "Bind the variables in ARGS to the elements of SEQUENCE, then evaluate BODY.
ARGS can also include the `&rest' marker followed by a variable
-name to be bound to the rest of SEQ."
+name to be bound to the rest of SEQUENCE."
(declare (indent 2) (debug t))
- `(pcase-let ((,(seq--make-pcase-patterns args) ,seq))
+ `(pcase-let ((,(seq--make-pcase-patterns args) ,sequence))
,@body))
-;;; Basic seq functions that have to be implemented by new seq types
-(cl-defgeneric seq-elt (seq n)
- "Return the element of SEQ at index N."
- (elt seq n))
+;;; Basic seq functions that have to be implemented by new sequence types
+(cl-defgeneric seq-elt (sequence n)
+ "Return Nth element of SEQUENCE."
+ (elt sequence n))
;; Default gv setters for `seq-elt'.
;; It can be a good idea for new sequence implementations to provide a
;; "gv-setter" for `seq-elt'.
-(cl-defmethod (setf seq-elt) (store (seq array) n)
- (aset seq n store))
+(cl-defmethod (setf seq-elt) (store (sequence array) n)
+ (aset sequence n store))
-(cl-defmethod (setf seq-elt) (store (seq cons) n)
- (setcar (nthcdr n seq) store))
+(cl-defmethod (setf seq-elt) (store (sequence cons) n)
+ (setcar (nthcdr n sequence) store))
-(cl-defgeneric seq-length (seq)
- "Return the length of the sequence SEQ."
- (length seq))
+(cl-defgeneric seq-length (sequence)
+ "Return the number of elements of SEQUENCE."
+ (length sequence))
-(cl-defgeneric seq-do (function seq)
- "Apply FUNCTION to each element of SEQ, presumably for side effects.
-Return SEQ."
- (mapc function seq))
+(cl-defgeneric seq-do (function sequence)
+ "Apply FUNCTION to each element of SEQUENCE, presumably for side effects.
+Return SEQUENCE."
+ (mapc function sequence))
(defalias 'seq-each #'seq-do)
-(cl-defgeneric seq-p (seq)
- "Return non-nil if SEQ is a sequence, nil otherwise."
- (sequencep seq))
+(cl-defgeneric seq-p (sequence)
+ "Return non-nil if SEQUENCE is a sequence, nil otherwise."
+ (sequencep sequence))
-(cl-defgeneric seq-copy (seq)
- "Return a shallow copy of SEQ."
- (copy-sequence seq))
+(cl-defgeneric seq-copy (sequence)
+ "Return a shallow copy of SEQUENCE."
+ (copy-sequence sequence))
-(cl-defgeneric seq-subseq (seq start &optional end)
- "Return the subsequence of SEQ from START to END.
-If END is omitted, it defaults to the length of the sequence.
-If START or END is negative, it counts from the end.
-Signal an error if START or END are outside of the sequence (i.e
-too large if positive or too small if negative)."
- (cl-subseq seq start end))
+(cl-defgeneric seq-subseq (sequence start &optional end)
+ "Return the sequence of elements of SEQUENCE from START to END.
+END is inclusive.
+
+If END is omitted, it defaults to the length of the sequence. If
+START or END is negative, it counts from the end. Signal an
+error if START or END are outside of the sequence (i.e too large
+if positive or too small if negative)."
+ (cl-subseq sequence start end))
-(cl-defgeneric seq-map (function seq)
- "Return the result of applying FUNCTION to each element of SEQ."
+(cl-defgeneric seq-map (function sequence)
+ "Return the result of applying FUNCTION to each element of SEQUENCE."
(let (result)
(seq-do (lambda (elt)
(push (funcall function elt) result))
- seq)
+ sequence)
(nreverse result)))
;; faster implementation for sequences (sequencep)
-(cl-defmethod seq-map (function (seq sequence))
- (mapcar function seq))
+(cl-defmethod seq-map (function (sequence sequence))
+ (mapcar function sequence))
+
+(cl-defgeneric seq-mapn (function sequence &rest sequences)
+ "Like `seq-map' but FUNCTION is mapped over all SEQUENCES.
+The arity of FUNCTION must match the number of SEQUENCES, and the
+mapping stops on the shortest sequence.
+Return a list of the results.
+
+\(fn FUNCTION SEQUENCES...)"
+ (let ((result nil)
+ (sequences (seq-map (lambda (s) (seq-into s 'list))
+ (cons sequence sequences))))
+ (while (not (memq nil sequences))
+ (push (apply function (seq-map #'car sequences)) result)
+ (setq sequences (seq-map #'cdr sequences)))
+ (nreverse result)))
-(cl-defgeneric seq-drop (seq n)
- "Return a subsequence of SEQ without its first N elements.
-The result is a sequence of the same type as SEQ.
+(cl-defgeneric seq-drop (sequence n)
+ "Remove the first N elements of SEQUENCE and return the result.
+The result is a sequence of the same type as SEQUENCE.
-If N is a negative integer or zero, SEQ is returned."
+If N is a negative integer or zero, SEQUENCE is returned."
(if (<= n 0)
- seq
- (let ((length (seq-length seq)))
- (seq-subseq seq (min n length) length))))
+ sequence
+ (let ((length (seq-length sequence)))
+ (seq-subseq sequence (min n length) length))))
-(cl-defgeneric seq-take (seq n)
- "Return a subsequence of SEQ with its first N elements.
-The result is a sequence of the same type as SEQ.
+(cl-defgeneric seq-take (sequence n)
+ "Take the first N elements of SEQUENCE and return the result.
+The result is a sequence of the same type as SEQUENCE.
If N is a negative integer or zero, an empty sequence is
returned."
- (seq-subseq seq 0 (min (max n 0) (seq-length seq))))
-
-(cl-defgeneric seq-drop-while (pred seq)
- "Return a sequence from the first element for which (PRED element) is nil in
SEQ.
-The result is a sequence of the same type as SEQ."
- (seq-drop seq (seq--count-successive pred seq)))
-
-(cl-defgeneric seq-take-while (pred seq)
- "Return the successive elements for which (PRED element) is non-nil in SEQ.
-The result is a sequence of the same type as SEQ."
- (seq-take seq (seq--count-successive pred seq)))
-
-(cl-defgeneric seq-empty-p (seq)
- "Return non-nil if the sequence SEQ is empty, nil otherwise."
- (= 0 (seq-length seq)))
-
-(cl-defgeneric seq-sort (pred seq)
- "Return a sorted sequence comparing using PRED the elements of SEQ.
-The result is a sequence of the same type as SEQ."
- (let ((result (seq-sort pred (append seq nil))))
- (seq-into result (type-of seq))))
+ (seq-subseq sequence 0 (min (max n 0) (seq-length sequence))))
+
+(cl-defgeneric seq-drop-while (pred sequence)
+ "Remove the successive elements of SEQUENCE for which PRED returns non-nil.
+PRED is a function of one argument. The result is a sequence of
+the same type as SEQUENCE."
+ (seq-drop sequence (seq--count-successive pred sequence)))
+
+(cl-defgeneric seq-take-while (pred sequence)
+ "Take the successive elements of SEQUENCE for which PRED returns non-nil.
+PRED is a function of one argument. The result is a sequence of
+the same type as SEQUENCE."
+ (seq-take sequence (seq--count-successive pred sequence)))
+
+(cl-defgeneric seq-empty-p (sequence)
+ "Return non-nil if the SEQUENCE is empty, nil otherwise."
+ (= 0 (seq-length sequence)))
+
+(cl-defgeneric seq-sort (pred sequence)
+ "Sort SEQUENCE using PRED as comparison function.
+The result is a sequence of the same type as SEQUENCE."
+ (let ((result (seq-sort pred (append sequence nil))))
+ (seq-into result (type-of sequence))))
(cl-defmethod seq-sort (pred (list list))
(sort (seq-copy list) pred))
-(cl-defgeneric seq-reverse (seq)
- "Return the reversed shallow copy of SEQ."
+(cl-defgeneric seq-reverse (sequence)
+ "Return a sequence with elements of SEQUENCE in reverse order."
(let ((result '()))
(seq-map (lambda (elt)
(push elt result))
- seq)
- (seq-into result (type-of seq))))
+ sequence)
+ (seq-into result (type-of sequence))))
;; faster implementation for sequences (sequencep)
-(cl-defmethod seq-reverse ((seq sequence))
- (reverse seq))
+(cl-defmethod seq-reverse ((sequence sequence))
+ (reverse sequence))
-(cl-defgeneric seq-concatenate (type &rest seqs)
- "Concatenate, into a sequence of type TYPE, the sequences SEQS.
+(cl-defgeneric seq-concatenate (type &rest sequences)
+ "Concatenate SEQUENCES into a single sequence of type TYPE.
TYPE must be one of following symbols: vector, string or list.
\n(fn TYPE SEQUENCE...)"
- (apply #'cl-concatenate type (seq-map #'seq-into-sequence seqs)))
+ (apply #'cl-concatenate type (seq-map #'seq-into-sequence sequences)))
-(cl-defgeneric seq-into-sequence (seq)
- "Convert SEQ into a sequence.
+(cl-defgeneric seq-into-sequence (sequence)
+ "Convert SEQUENCE into a sequence.
-The default implementation is to signal an error if SEQ is not a
+The default implementation is to signal an error if SEQUENCE is not a
sequence, specific functions should be implemented for new types
-of seq."
- (unless (sequencep seq)
- (error "Cannot convert %S into a sequence" seq))
- seq)
-
-(cl-defgeneric seq-into (seq type)
- "Convert the sequence SEQ into a sequence of type TYPE.
-TYPE can be one of the following symbols: vector, string or list."
+of sequence."
+ (unless (sequencep sequence)
+ (error "Cannot convert %S into a sequence" sequence))
+ sequence)
+
+(cl-defgeneric seq-into (sequence type)
+ "Concatenate the elements of SEQUENCE into a sequence of type TYPE.
+TYPE can be one of the following symbols: vector, string or
+list."
(pcase type
- (`vector (vconcat seq))
- (`string (concat seq))
- (`list (append seq nil))
+ (`vector (vconcat sequence))
+ (`string (concat sequence))
+ (`list (append sequence nil))
(_ (error "Not a sequence type name: %S" type))))
-(cl-defgeneric seq-filter (pred seq)
- "Return a list of all the elements for which (PRED element) is non-nil in
SEQ."
+(cl-defgeneric seq-filter (pred sequence)
+ "Return a list of all the elements for which (PRED element) is non-nil in
SEQUENCE."
(let ((exclude (make-symbol "exclude")))
(delq exclude (seq-map (lambda (elt)
(if (funcall pred elt)
elt
exclude))
- seq))))
+ sequence))))
-(cl-defgeneric seq-remove (pred seq)
- "Return a list of all the elements for which (PRED element) is nil in SEQ."
+(cl-defgeneric seq-remove (pred sequence)
+ "Return a list of all the elements for which (PRED element) is nil in
SEQUENCE."
(seq-filter (lambda (elt) (not (funcall pred elt)))
- seq))
+ sequence))
-(cl-defgeneric seq-reduce (function seq initial-value)
- "Reduce the function FUNCTION across SEQ, starting with INITIAL-VALUE.
+(cl-defgeneric seq-reduce (function sequence initial-value)
+ "Reduce the function FUNCTION across SEQUENCE, starting with INITIAL-VALUE.
Return the result of calling FUNCTION with INITIAL-VALUE and the
-first element of SEQ, then calling FUNCTION with that result and
-the second element of SEQ, then with that result and the third
-element of SEQ, etc.
+first element of SEQUENCE, then calling FUNCTION with that result and
+the second element of SEQUENCE, then with that result and the third
+element of SEQUENCE, etc.
-If SEQ is empty, return INITIAL-VALUE and FUNCTION is not called."
- (if (seq-empty-p seq)
+If SEQUENCE is empty, return INITIAL-VALUE and FUNCTION is not called."
+ (if (seq-empty-p sequence)
initial-value
(let ((acc initial-value))
- (seq-doseq (elt seq)
+ (seq-doseq (elt sequence)
(setq acc (funcall function acc elt)))
acc)))
-(cl-defgeneric seq-every-p (pred seq)
- "Return non-nil if (PRED element) is non-nil for all elements of the
sequence SEQ."
+(cl-defgeneric seq-every-p (pred sequence)
+ "Return non-nil if (PRED element) is non-nil for all elements of SEQUENCE."
(catch 'seq--break
- (seq-doseq (elt seq)
+ (seq-doseq (elt sequence)
(or (funcall pred elt)
(throw 'seq--break nil)))
t))
-(cl-defgeneric seq-some (pred seq)
- "Return the first value for which if (PRED element) is non-nil for in SEQ."
+(cl-defgeneric seq-some (pred sequence)
+ "Return the first value for which if (PRED element) is non-nil for in
SEQUENCE."
(catch 'seq--break
- (seq-doseq (elt seq)
+ (seq-doseq (elt sequence)
(let ((result (funcall pred elt)))
(when result
(throw 'seq--break result))))
nil))
-(cl-defgeneric seq-find (pred seq &optional default)
- "Return the first element for which (PRED element) is non-nil in SEQ.
+(cl-defgeneric seq-find (pred sequence &optional default)
+ "Return the first element for which (PRED element) is non-nil in SEQUENCE.
If no element is found, return DEFAULT.
Note that `seq-find' has an ambiguity if the found element is
identical to DEFAULT, as it cannot be known if an element was
found or not."
(catch 'seq--break
- (seq-doseq (elt seq)
+ (seq-doseq (elt sequence)
(when (funcall pred elt)
(throw 'seq--break elt)))
default))
-(cl-defgeneric seq-count (pred seq)
- "Return the number of elements for which (PRED element) is non-nil in SEQ."
+(cl-defgeneric seq-count (pred sequence)
+ "Return the number of elements for which (PRED element) is non-nil in
SEQUENCE."
(let ((count 0))
- (seq-doseq (elt seq)
+ (seq-doseq (elt sequence)
(when (funcall pred elt)
(setq count (+ 1 count))))
count))
-(cl-defgeneric seq-contains (seq elt &optional testfn)
- "Return the first element in SEQ that is equal to ELT.
+(cl-defgeneric seq-contains (sequence elt &optional testfn)
+ "Return the first element in SEQUENCE that is equal to ELT.
Equality is defined by TESTFN if non-nil or by `equal' if nil."
(seq-some (lambda (e)
(funcall (or testfn #'equal) elt e))
- seq))
+ sequence))
-(cl-defgeneric seq-position (seq elt &optional testfn)
- "Return the index of the first element in SEQ that is equal to ELT.
+(cl-defgeneric seq-position (sequence elt &optional testfn)
+ "Return the index of the first element in SEQUENCE that is equal to ELT.
Equality is defined by TESTFN if non-nil or by `equal' if nil."
(let ((index 0))
(catch 'seq--break
- (seq-doseq (e seq)
+ (seq-doseq (e sequence)
(when (funcall (or testfn #'equal) e elt)
(throw 'seq--break index))
(setq index (1+ index)))
nil)))
-(cl-defgeneric seq-uniq (seq &optional testfn)
- "Return a list of the elements of SEQ with duplicates removed.
+(cl-defgeneric seq-uniq (sequence &optional testfn)
+ "Return a list of the elements of SEQUENCE with duplicates removed.
TESTFN is used to compare elements, or `equal' if TESTFN is nil."
(let ((result '()))
- (seq-doseq (elt seq)
+ (seq-doseq (elt sequence)
(unless (seq-contains result elt testfn)
(setq result (cons elt result))))
(nreverse result)))
-(cl-defgeneric seq-mapcat (function seq &optional type)
- "Concatenate the result of applying FUNCTION to each element of SEQ.
+(cl-defgeneric seq-mapcat (function sequence &optional type)
+ "Concatenate the result of applying FUNCTION to each element of SEQUENCE.
The result is a sequence of type TYPE, or a list if TYPE is nil."
(apply #'seq-concatenate (or type 'list)
- (seq-map function seq)))
+ (seq-map function sequence)))
-(cl-defgeneric seq-partition (seq n)
- "Return a list of the elements of SEQ grouped into sub-sequences of length N.
+(cl-defgeneric seq-partition (sequence n)
+ "Return a list of the elements of SEQUENCE grouped into sub-sequences of
length N.
The last sequence may contain less than N elements. If N is a
negative integer or 0, nil is returned."
(unless (< n 1)
(let ((result '()))
- (while (not (seq-empty-p seq))
- (push (seq-take seq n) result)
- (setq seq (seq-drop seq n)))
+ (while (not (seq-empty-p sequence))
+ (push (seq-take sequence n) result)
+ (setq sequence (seq-drop sequence n)))
(nreverse result))))
-(cl-defgeneric seq-intersection (seq1 seq2 &optional testfn)
- "Return a list of the elements that appear in both SEQ1 and SEQ2.
+(cl-defgeneric seq-intersection (sequence1 sequence2 &optional testfn)
+ "Return a list of the elements that appear in both SEQUENCE1 and SEQUENCE2.
Equality is defined by TESTFN if non-nil or by `equal' if nil."
(seq-reduce (lambda (acc elt)
- (if (seq-contains seq2 elt testfn)
+ (if (seq-contains sequence2 elt testfn)
(cons elt acc)
acc))
- (seq-reverse seq1)
+ (seq-reverse sequence1)
'()))
-(cl-defgeneric seq-difference (seq1 seq2 &optional testfn)
- "Return a list of the elements that appear in SEQ1 but not in SEQ2.
+(cl-defgeneric seq-difference (sequence1 sequence2 &optional testfn)
+ "Return a list of the elements that appear in SEQUENCE1 but not in SEQUENCE2.
Equality is defined by TESTFN if non-nil or by `equal' if nil."
(seq-reduce (lambda (acc elt)
- (if (not (seq-contains seq2 elt testfn))
+ (if (not (seq-contains sequence2 elt testfn))
(cons elt acc)
acc))
- (seq-reverse seq1)
+ (seq-reverse sequence1)
'()))
-(cl-defgeneric seq-group-by (function seq)
- "Apply FUNCTION to each element of SEQ.
-Separate the elements of SEQ into an alist using the results as
+(cl-defgeneric seq-group-by (function sequence)
+ "Apply FUNCTION to each element of SEQUENCE.
+Separate the elements of SEQUENCE into an alist using the results as
keys. Keys are compared using `equal'."
(seq-reduce
(lambda (acc elt)
@@ -369,25 +389,25 @@ keys. Keys are compared using `equal'."
(setcdr cell (push elt (cdr cell)))
(push (list key elt) acc))
acc))
- (seq-reverse seq)
+ (seq-reverse sequence)
nil))
-(cl-defgeneric seq-min (seq)
- "Return the smallest element of SEQ.
-SEQ must be a sequence of numbers or markers."
- (apply #'min (seq-into seq 'list)))
+(cl-defgeneric seq-min (sequence)
+ "Return the smallest element of SEQUENCE.
+SEQUENCE must be a sequence of numbers or markers."
+ (apply #'min (seq-into sequence 'list)))
-(cl-defgeneric seq-max (seq)
- "Return the largest element of SEQ.
-SEQ must be a sequence of numbers or markers."
- (apply #'max (seq-into seq 'list)))
+(cl-defgeneric seq-max (sequence)
+ "Return the largest element of SEQUENCE.
+SEQUENCE must be a sequence of numbers or markers."
+ (apply #'max (seq-into sequence 'list)))
-(defun seq--count-successive (pred seq)
- "Return the number of successive elements for which (PRED element) is
non-nil in SEQ."
+(defun seq--count-successive (pred sequence)
+ "Return the number of successive elements for which (PRED element) is
non-nil in SEQUENCE."
(let ((n 0)
- (len (seq-length seq)))
+ (len (seq-length sequence)))
(while (and (< n len)
- (funcall pred (seq-elt seq n)))
+ (funcall pred (seq-elt sequence n)))
(setq n (+ 1 n)))
n))
@@ -419,10 +439,10 @@ SEQ must be a sequence of numbers or markers."
args)))
;; TODO: make public?
-(defun seq--elt-safe (seq n)
- "Return element of SEQ at the index N.
+(defun seq--elt-safe (sequence n)
+ "Return element of SEQUENCE at the index N.
If no element is found, return nil."
- (ignore-errors (seq-elt seq n)))
+ (ignore-errors (seq-elt sequence n)))
;;; Optimized implementations for lists
diff --git a/lisp/emacs-lisp/thunk.el b/lisp/emacs-lisp/thunk.el
new file mode 100644
index 0000000..0c5816a
--- /dev/null
+++ b/lisp/emacs-lisp/thunk.el
@@ -0,0 +1,74 @@
+;;; thunk.el --- Lazy form evaluation -*- lexical-binding: t -*-
+
+;; Copyright (C) 2015 Free Software Foundation, Inc.
+
+;; Author: Nicolas Petton <address@hidden>
+;; Keywords: sequences
+;; Version: 1.0
+;; Package: thunk
+
+;; Maintainer: address@hidden
+
+;; 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:
+;;
+;; Thunk provides functions and macros to delay the evaluation of
+;; forms.
+;;
+;; Use `thunk-delay' to delay the evaluation of a form, and
+;; `thunk-force' to evaluate it. The result of the evaluation is
+;; cached, and only happens once.
+;;
+;; Here is an example of a form which evaluation is delayed:
+;;
+;; (setq delayed (thunk-delay (message "this message is delayed")))
+;;
+;; `delayed' is not evaluated until `thunk-force' is called, like the
+;; following:
+;;
+;; (thunk-force delayed)
+
+;; Tests are located at test/automated/thunk-tests.el
+
+;;; Code:
+
+(defmacro thunk-delay (&rest body)
+ "Delay the evaluation of BODY."
+ (declare (debug t))
+ (let ((forced (make-symbol "forced"))
+ (val (make-symbol "val")))
+ `(let (,forced ,val)
+ (lambda (&optional check)
+ (if check
+ ,forced
+ (unless ,forced
+ (setf ,val (progn ,@body))
+ (setf ,forced t))
+ ,val)))))
+
+(defun thunk-force (delayed)
+ "Force the evaluation of DELAYED.
+The result is cached and will be returned on subsequent calls
+with the same DELAYED argument."
+ (funcall delayed))
+
+(defun thunk-evaluated-p (delayed)
+ "Return non-nil if DELAYED has been evaluated."
+ (funcall delayed t))
+
+(provide 'thunk)
+;;; thunk.el ends here
diff --git a/lisp/eshell/esh-mode.el b/lisp/eshell/esh-mode.el
index 3df820d..9cc9d34 100644
--- a/lisp/eshell/esh-mode.el
+++ b/lisp/eshell/esh-mode.el
@@ -877,9 +877,8 @@ If SCROLLBACK is non-nil, clear the scrollback contents."
(interactive)
(if scrollback
(eshell/clear-scrollback)
- (let ((number-newlines (count-lines (window-start) (point))))
- (insert (make-string number-newlines ?\n))
- (eshell-send-input))))
+ (insert (make-string (window-size) ?\n))
+ (eshell-send-input)))
(defun eshell/clear-scrollback ()
"Clear the scrollback content of the eshell window."
diff --git a/lisp/filenotify.el b/lisp/filenotify.el
index a07f99a..6a180a8 100644
--- a/lisp/filenotify.el
+++ b/lisp/filenotify.el
@@ -48,6 +48,34 @@ The value in the hash table is a list
Several values for a given DIR happen only for `inotify', when
different files from the same directory are watched.")
+(defun file-notify--rm-descriptor (descriptor &optional what)
+ "Remove DESCRIPTOR from `file-notify-descriptors'.
+DESCRIPTOR should be an object returned by `file-notify-add-watch'.
+If it is registered in `file-notify-descriptors', a stopped event is sent.
+WHAT is a file or directory name to be removed, needed just for `inotify'."
+ (let* ((desc (if (consp descriptor) (car descriptor) descriptor))
+ (file (if (consp descriptor) (cdr descriptor)))
+ (registered (gethash desc file-notify-descriptors))
+ (dir (car registered)))
+
+ (when (and (consp registered) (or (null what) (string-equal dir what)))
+ ;; Send `stopped' event.
+ (dolist (entry (cdr registered))
+ (funcall (cdr entry)
+ `(,(file-notify--descriptor desc) stopped
+ ,(or (and (stringp (car entry))
+ (expand-file-name (car entry) dir))
+ dir))))
+
+ ;; Modify `file-notify-descriptors'.
+ (if (not file)
+ (remhash desc file-notify-descriptors)
+ (setcdr registered
+ (delete (assoc file (cdr registered)) (cdr registered)))
+ (if (null (cdr registered))
+ (remhash desc file-notify-descriptors)
+ (puthash desc registered file-notify-descriptors))))))
+
;; This function is used by `gfilenotify', `inotify' and `w32notify' events.
;;;###autoload
(defun file-notify-handle-event (event)
@@ -58,6 +86,7 @@ If EVENT is a filewatch event, call its callback. It has the
format
Otherwise, signal a `file-notify-error'."
(interactive "e")
+ ;;(message "file-notify-handle-event %S" event)
(if (and (eq (car event) 'file-notify)
(>= (length event) 3))
(funcall (nth 2 event) (nth 1 event))
@@ -111,7 +140,7 @@ EVENT is the cadr of the event in `file-notify-handle-event'
(registered (gethash desc file-notify-descriptors))
(actions (nth 1 event))
(file (file-notify--event-file-name event))
- file1 callback pending-event)
+ file1 callback pending-event stopped)
;; Make actions a list.
(unless (consp actions) (setq actions (cons actions nil)))
@@ -158,6 +187,8 @@ EVENT is the cadr of the event in `file-notify-handle-event'
'renamed)
;; inotify, w32notify.
+ ((eq action 'ignored)
+ (setq stopped t actions nil))
((eq action 'attrib) 'attribute-changed)
((memq action '(create added)) 'created)
((memq action '(modify modified)) 'changed)
@@ -194,6 +225,20 @@ EVENT is the cadr of the event in
`file-notify-handle-event'
(funcall (cadr pending-event) (car pending-event))
(setq pending-event nil))
+ ;; Check for stopped.
+ ;;(message "file-notify-callback %S %S" file registered)
+ (setq
+ stopped
+ (or
+ stopped
+ (and
+ (memq action '(deleted renamed))
+ (= (length (cdr registered)) 1)
+ (string-equal
+ (file-name-nondirectory file)
+ (or (file-name-nondirectory (car registered))
+ (car (cadr registered)))))))
+
;; Apply callback.
(when (and action
(or
@@ -213,7 +258,11 @@ EVENT is the cadr of the event in
`file-notify-handle-event'
`(,(file-notify--descriptor desc) ,action ,file ,file1))
(funcall
callback
- `(,(file-notify--descriptor desc) ,action ,file))))))))
+ `(,(file-notify--descriptor desc) ,action ,file)))))
+
+ ;; Modify `file-notify-descriptors'.
+ (when stopped
+ (file-notify--rm-descriptor (file-notify--descriptor desc) file)))))
;; `gfilenotify' and `w32notify' return a unique descriptor for every
;; `file-notify-add-watch', while `inotify' returns a unique
@@ -251,17 +300,18 @@ following:
`changed' -- FILE has changed
`renamed' -- FILE has been renamed to FILE1
`attribute-changed' -- a FILE attribute was changed
+ `stopped' -- watching FILE has been stopped
FILE is the name of the file whose event is being reported."
;; Check arguments.
(unless (stringp file)
- (signal 'wrong-type-argument (list file)))
+ (signal 'wrong-type-argument `(,file)))
(setq file (expand-file-name file))
(unless (and (consp flags)
(null (delq 'change (delq 'attribute-change (copy-tree flags)))))
- (signal 'wrong-type-argument (list flags)))
+ (signal 'wrong-type-argument `(,flags)))
(unless (functionp callback)
- (signal 'wrong-type-argument (list callback)))
+ (signal 'wrong-type-argument `(,callback)))
(let* ((handler (find-file-name-handler file 'file-notify-add-watch))
(dir (directory-file-name
@@ -270,14 +320,17 @@ FILE is the name of the file whose event is being
reported."
(file-name-directory file))))
desc func l-flags registered)
+ (unless (file-directory-p dir)
+ (signal 'file-notify-error `("Directory does not exist" ,dir)))
+
(if handler
;; A file name handler could exist even if there is no local
;; file notification support.
(setq desc (funcall
handler 'file-notify-add-watch dir flags callback))
- ;; Check, whether Emacs has been compiled with file
- ;; notification support.
+ ;; Check, whether Emacs has been compiled with file notification
+ ;; support.
(unless file-notify--library
(signal 'file-notify-error
'("No file notification package available")))
@@ -296,7 +349,8 @@ FILE is the name of the file whose event is being reported."
(setq
l-flags
(cond
- ((eq file-notify--library 'inotify) '(create modify move delete))
+ ((eq file-notify--library 'inotify)
+ '(create delete delete-self modify move-self move))
((eq file-notify--library 'w32notify)
'(file-name directory-name size last-write-time)))))
(when (memq 'attribute-change flags)
@@ -326,14 +380,16 @@ FILE is the name of the file whose event is being
reported."
DESCRIPTOR should be an object returned by `file-notify-add-watch'."
(let* ((desc (if (consp descriptor) (car descriptor) descriptor))
(file (if (consp descriptor) (cdr descriptor)))
- (dir (car (gethash desc file-notify-descriptors)))
+ (registered (gethash desc file-notify-descriptors))
+ (dir (car registered))
(handler (and (stringp dir)
- (find-file-name-handler dir 'file-notify-rm-watch)))
- (registered (gethash desc file-notify-descriptors)))
+ (find-file-name-handler dir 'file-notify-rm-watch))))
(when (stringp dir)
;; Call low-level function.
- (when (null (cdr registered))
+ (when (or (not file)
+ (and (= (length (cdr registered)) 1)
+ (assoc file (cdr registered))))
(condition-case nil
(if handler
;; A file name handler could exist even if there is no local
@@ -349,14 +405,7 @@ DESCRIPTOR should be an object returned by
`file-notify-add-watch'."
(file-notify-error nil)))
;; Modify `file-notify-descriptors'.
- (if (not file)
- (remhash desc file-notify-descriptors)
-
- (setcdr registered
- (delete (assoc file (cdr registered)) (cdr registered)))
- (if (null (cdr registered))
- (remhash desc file-notify-descriptors)
- (puthash desc registered file-notify-descriptors))))))
+ (file-notify--rm-descriptor descriptor))))
(defun file-notify-valid-p (descriptor)
"Check a watch specified by its DESCRIPTOR.
diff --git a/lisp/files.el b/lisp/files.el
index d0e3e68..b25994c 100644
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -4041,7 +4041,7 @@ Interactively, confirmation is required unless you supply
a prefix argument."
(save-buffer)
;; It's likely that the VC status at the new location is different from
;; the one at the old location.
- (vc-find-file-hook))
+ (vc-refresh-state))
(defun file-extended-attributes (filename)
"Return an alist of extended attributes of file FILENAME.
diff --git a/lisp/gnus/auth-source.el b/lisp/gnus/auth-source.el
index 75e6d04..304bfa9 100644
--- a/lisp/gnus/auth-source.el
+++ b/lisp/gnus/auth-source.el
@@ -63,10 +63,10 @@
(autoload 'plstore-save "plstore")
(autoload 'plstore-get-file "plstore")
+(eval-when-compile (require 'epg)) ;; setf-method for `epg-context-armor'
(autoload 'epg-make-context "epg")
(autoload 'epg-context-set-passphrase-callback "epg")
(autoload 'epg-decrypt-string "epg")
-(autoload 'epg-context-set-armor "epg")
(autoload 'epg-encrypt-string "epg")
(autoload 'help-mode "help-mode" nil t)
diff --git a/lisp/gnus/gnus-topic.el b/lisp/gnus/gnus-topic.el
index 7c6e109..b989783 100644
--- a/lisp/gnus/gnus-topic.el
+++ b/lisp/gnus/gnus-topic.el
@@ -508,7 +508,6 @@ articles in the topic and its subtopics."
(all-entries entries)
(point-max (point-max))
(unread 0)
- (topic (car type))
info entry end active tick)
;; Insert any sub-topics.
(while topicl
@@ -586,7 +585,7 @@ articles in the topic and its subtopics."
(goto-char end)
unread))
-(defun gnus-topic-remove-topic (&optional insert total-remove hide in-level)
+(defun gnus-topic-remove-topic (&optional insert total-remove _hide in-level)
"Remove the current topic."
(let ((topic (gnus-group-topic-name))
(level (gnus-group-topic-level))
@@ -631,6 +630,8 @@ articles in the topic and its subtopics."
(or insert (not (gnus-topic-visible-p))) nil nil 9)
(gnus-topic-enter-dribble)))))))
+(defvar gnus-tmp-header)
+
(defun gnus-topic-insert-topic-line (name visiblep shownp level entries
&optional unread)
(let* ((visible (if visiblep "" "..."))
@@ -694,8 +695,7 @@ articles in the topic and its subtopics."
(let* ((topic (gnus-group-topic group))
(groups (cdr (assoc topic gnus-topic-alist)))
(g (cdr (member group groups)))
- (unfound t)
- entry)
+ (unfound t))
;; Try to jump to a visible group.
(while (and g
(not (gnus-group-goto-group (car g) t)))
@@ -1454,7 +1454,7 @@ If NON-RECURSIVE (which is the prefix) is t, don't mark
its subtopics."
(funcall (if unmark 'gnus-group-remove-mark 'gnus-group-set-mark)
(gnus-info-group (nth 2 (pop groups)))))))))
-(defun gnus-topic-unmark-topic (topic &optional dummy non-recursive)
+(defun gnus-topic-unmark-topic (topic &optional _dummy non-recursive)
"Remove the process mark from all groups in the TOPIC.
If NON-RECURSIVE (which is the prefix) is t, don't unmark its subtopics."
(interactive (list (gnus-group-topic-name)
@@ -1488,15 +1488,14 @@ If NON-RECURSIVE (which is the prefix) is t, don't
unmark its subtopics."
(gnus-group-mark-regexp regexp)
(gnus-topic-move-group nil topic copyp))
-(defun gnus-topic-copy-matching (regexp topic &optional copyp)
+(defun gnus-topic-copy-matching (regexp topic &optional _copyp)
"Copy all groups that match REGEXP to some topic."
(interactive
- (let (topic)
+ (let ((topic (gnus-completing-read "Copy to topic"
+ (mapcar #'car gnus-topic-alist) t)))
(nreverse
- (list
- (setq topic (gnus-completing-read "Copy to topic"
- (mapcar 'car gnus-topic-alist) t))
- (read-string (format "Copy to %s (regexp): " topic))))))
+ (list topic
+ (read-string (format "Copy to %s (regexp): " topic))))))
(gnus-topic-move-matching regexp topic t))
(defun gnus-topic-delete (topic)
diff --git a/lisp/help.el b/lisp/help.el
index 3387628..c558b65 100644
--- a/lisp/help.el
+++ b/lisp/help.el
@@ -1394,9 +1394,10 @@ ARGLIST can also be t or a string of the form \"(FUN
ARG1 ARG2 ...)\"."
(if (string-match "\n?\n\\'" docstring)
(if (< (- (match-end 0) (match-beginning 0)) 2) "\n" "")
"\n\n")
- (if (and (stringp arglist)
- (string-match "\\`([^ ]+\\(.*\\))\\'" arglist))
- (concat "(fn" (match-string 1 arglist) ")")
+ (if (stringp arglist)
+ (if (string-match "\\`[^ ]+\\(.*\\))\\'" arglist)
+ (concat "(fn" (match-string 1 arglist) ")")
+ (error "Unrecognized usage format"))
(help--make-usage-docstring 'fn arglist)))))
(defun help-function-arglist (def &optional preserve-names)
diff --git a/lisp/international/ccl.el b/lisp/international/ccl.el
index daba2b6..2fcbc88 100644
--- a/lisp/international/ccl.el
+++ b/lisp/international/ccl.el
@@ -1,4 +1,4 @@
-;;; ccl.el --- CCL (Code Conversion Language) compiler
+;;; ccl.el --- CCL (Code Conversion Language) compiler -*- lexical-binding:t
-*-
;; Copyright (C) 1997-1998, 2001-2015 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
@@ -479,8 +479,7 @@ If READ-FLAG is non-nil, this statement has the form
(let ((condition (nth 1 cmd))
(true-cmds (nth 2 cmd))
(false-cmds (nth 3 cmd))
- jump-cond-address
- false-ic)
+ jump-cond-address)
(if (and (listp condition)
(listp (car condition)))
;; If CONDITION is a nested expression, the inner expression
@@ -678,8 +677,7 @@ is a list of CCL-BLOCKs."
(ccl-embed-code 'write-const-jump 0 ccl-loop-head)
(ccl-embed-data arg))
((stringp arg)
- (let ((len (length arg))
- (i 0))
+ (let ((len (length arg)))
(ccl-embed-code 'write-string-jump 0 ccl-loop-head)
(ccl-embed-data len)
(ccl-embed-string len arg)))
@@ -920,8 +918,7 @@ is a list of CCL-BLOCKs."
(error "CCL: Invalid number of arguments: %s" cmd))
(let ((RRR (nth 1 cmd))
(rrr (nth 2 cmd))
- (map (nth 3 cmd))
- id)
+ (map (nth 3 cmd)))
(ccl-check-register rrr cmd)
(ccl-check-register RRR cmd)
(ccl-embed-extended-command 'map-single rrr RRR 0)
@@ -962,10 +959,11 @@ is a list of CCL-BLOCKs."
(defvar ccl-code)
;;;###autoload
-(defun ccl-dump (ccl-code)
- "Disassemble compiled CCL-CODE."
- (let ((len (length ccl-code))
- (buffer-mag (aref ccl-code 0)))
+(defun ccl-dump (code)
+ "Disassemble compiled CCL-code CODE."
+ (let* ((ccl-code code)
+ (len (length ccl-code))
+ (buffer-mag (aref ccl-code 0)))
(cond ((= buffer-mag 0)
(insert (substitute-command-keys "Don't output anything.\n")))
((= buffer-mag 1)
@@ -1005,7 +1003,7 @@ is a list of CCL-BLOCKs."
(defun ccl-dump-set-short-const (rrr cc)
(insert (format "r%d = %d\n" rrr cc)))
-(defun ccl-dump-set-const (rrr ignore)
+(defun ccl-dump-set-const (rrr _ignore)
(insert (format "r%d = %d\n" rrr (ccl-get-next-code))))
(defun ccl-dump-set-array (rrr cc)
@@ -1019,7 +1017,7 @@ is a list of CCL-BLOCKs."
(setq i (1+ i)))
(insert "\n")))
-(defun ccl-dump-jump (ignore cc &optional address)
+(defun ccl-dump-jump (_ignore cc &optional address)
(insert (format "jump to %d(" (+ (or address ccl-current-ic) cc)))
(if (>= cc 0)
(insert "+"))
@@ -1042,13 +1040,13 @@ is a list of CCL-BLOCKs."
(defun ccl-extract-arith-op (cc)
(aref ccl-arith-table (ash cc -6)))
-(defun ccl-dump-write-expr-const (ignore cc)
+(defun ccl-dump-write-expr-const (_ignore cc)
(insert (format "write (r%d %s %d)\n"
(logand cc 7)
(ccl-extract-arith-op cc)
(ccl-get-next-code))))
-(defun ccl-dump-write-expr-register (ignore cc)
+(defun ccl-dump-write-expr-register (_ignore cc)
(insert (format "write (r%d %s r%d)\n"
(logand cc 7)
(ccl-extract-arith-op cc)
@@ -1059,7 +1057,7 @@ is a list of CCL-BLOCKs."
((= cc ?\n) (insert " \"^J\""))
(t (insert (format " \"%c\"" cc)))))
-(defun ccl-dump-write-const-jump (ignore cc)
+(defun ccl-dump-write-const-jump (_ignore cc)
(let ((address ccl-current-ic))
(insert "write char")
(ccl-dump-insert-char (ccl-get-next-code))
@@ -1075,7 +1073,7 @@ is a list of CCL-BLOCKs."
(ccl-get-next-code) ; Skip dummy READ-JUMP
))
-(defun ccl-dump-write-string-jump (ignore cc)
+(defun ccl-dump-write-string-jump (_ignore cc)
(let ((address ccl-current-ic)
(len (ccl-get-next-code))
(i 0))
@@ -1125,7 +1123,7 @@ is a list of CCL-BLOCKs."
(defun ccl-dump-write-register (rrr cc)
(insert (format "write r%d (%d remaining)\n" rrr cc)))
-(defun ccl-dump-call (ignore cc)
+(defun ccl-dump-call (_ignore _cc)
(let ((subroutine (car (ccl-get-next-code))))
(insert (format-message "call subroutine `%s'\n" subroutine))))
@@ -1160,7 +1158,7 @@ is a list of CCL-BLOCKs."
(setq i (1+ i)))
(insert "\n")))
-(defun ccl-dump-end (&rest ignore)
+(defun ccl-dump-end (&rest _ignore)
(insert "end\n"))
(defun ccl-dump-set-assign-expr-const (rrr cc)
@@ -1213,9 +1211,10 @@ is a list of CCL-BLOCKs."
(insert (format "read r%d, " rrr))
(ccl-dump-jump-cond-expr-register rrr cc))
-(defun ccl-dump-binary (ccl-code)
- (let ((len (length ccl-code))
- (i 2))
+(defun ccl-dump-binary (code)
+ (let* ((ccl-code code)
+ (len (length ccl-code))
+ (i 2))
(while (< i len)
(let ((code (aref ccl-code i))
(j 27))
@@ -1235,28 +1234,28 @@ is a list of CCL-BLOCKs."
(insert (format "<%s> " ex-op))
(funcall (get ex-op 'ccl-dump-function) rrr RRR Rrr)))
-(defun ccl-dump-read-multibyte-character (rrr RRR Rrr)
+(defun ccl-dump-read-multibyte-character (rrr RRR _Rrr)
(insert (format "read-multibyte-character r%d r%d\n" RRR rrr)))
-(defun ccl-dump-write-multibyte-character (rrr RRR Rrr)
+(defun ccl-dump-write-multibyte-character (rrr RRR _Rrr)
(insert (format "write-multibyte-character r%d r%d\n" RRR rrr)))
(defun ccl-dump-translate-character (rrr RRR Rrr)
(insert (format "translation table(r%d) r%d r%d\n" Rrr RRR rrr)))
-(defun ccl-dump-translate-character-const-tbl (rrr RRR Rrr)
+(defun ccl-dump-translate-character-const-tbl (rrr RRR _Rrr)
(let ((tbl (ccl-get-next-code)))
(insert (format "translation table(%S) r%d r%d\n" tbl RRR rrr))))
-(defun ccl-dump-lookup-int-const-tbl (rrr RRR Rrr)
+(defun ccl-dump-lookup-int-const-tbl (rrr RRR _Rrr)
(let ((tbl (ccl-get-next-code)))
(insert (format "hash table(%S) r%d r%d\n" tbl RRR rrr))))
-(defun ccl-dump-lookup-char-const-tbl (rrr RRR Rrr)
+(defun ccl-dump-lookup-char-const-tbl (rrr RRR _Rrr)
(let ((tbl (ccl-get-next-code)))
(insert (format "hash table(%S) r%d r%d\n" tbl RRR rrr))))
-(defun ccl-dump-iterate-multiple-map (rrr RRR Rrr)
+(defun ccl-dump-iterate-multiple-map (rrr RRR _Rrr)
(let ((notbl (ccl-get-next-code))
(i 0) id)
(insert (format "iterate-multiple-map r%d r%d\n" RRR rrr))
@@ -1267,7 +1266,7 @@ is a list of CCL-BLOCKs."
(setq i (1+ i)))
(insert "]\n")))
-(defun ccl-dump-map-multiple (rrr RRR Rrr)
+(defun ccl-dump-map-multiple (rrr RRR _Rrr)
(let ((notbl (ccl-get-next-code))
(i 0) id)
(insert (format "map-multiple r%d r%d\n" RRR rrr))
@@ -1280,7 +1279,7 @@ is a list of CCL-BLOCKs."
(setq i (1+ i)))
(insert "]\n")))
-(defun ccl-dump-map-single (rrr RRR Rrr)
+(defun ccl-dump-map-single (rrr RRR _Rrr)
(let ((id (ccl-get-next-code)))
(insert (format "map-single r%d r%d map(%S)\n" RRR rrr id))))
diff --git a/lisp/isearch.el b/lisp/isearch.el
index 6b99da9..915255b 100644
--- a/lisp/isearch.el
+++ b/lisp/isearch.el
@@ -72,23 +72,20 @@
(defcustom search-exit-option t
"Non-nil means random control characters terminate incremental search."
- :type 'boolean
- :group 'isearch)
+ :type 'boolean)
(defcustom search-slow-window-lines 1
"Number of lines in slow search display windows.
These are the short windows used during incremental search on slow terminals.
Negative means put the slow search window at the top (normally it's at bottom)
and the value is minus the number of lines."
- :type 'integer
- :group 'isearch)
+ :type 'integer)
(defcustom search-slow-speed 1200
"Highest terminal speed at which to use \"slow\" style incremental search.
This is the style where a one-line window is created to show the line
that the search has reached."
- :type 'integer
- :group 'isearch)
+ :type 'integer)
(defcustom search-upper-case 'not-yanks
"If non-nil, upper case chars disable case fold searching.
@@ -99,15 +96,13 @@ If this value is `not-yanks', text yanked into the search
string
in Isearch mode is always downcased."
:type '(choice (const :tag "off" nil)
(const not-yanks)
- (other :tag "on" t))
- :group 'isearch)
+ (other :tag "on" t)))
(defcustom search-nonincremental-instead t
"If non-nil, do a nonincremental search instead of exiting immediately.
Actually, `isearch-edit-string' is called to let you enter the search
string, and RET terminates editing and does a nonincremental search."
- :type 'boolean
- :group 'isearch)
+ :type 'boolean)
(defcustom search-whitespace-regexp (purecopy "\\s-+")
"If non-nil, regular expression to match a sequence of whitespace chars.
@@ -127,7 +122,6 @@ In the Customization buffer, that is `[' followed by a
space,
a tab, a carriage return (control-M), a newline, and `]+'."
:type '(choice (const :tag "Match Spaces Literally" nil)
regexp)
- :group 'isearch
:version "24.3")
(defcustom search-invisible 'open
@@ -147,8 +141,7 @@ See also `reveal-mode' if you want overlays to
automatically be opened
whenever point is in one of them."
:type '(choice (const :tag "Match hidden text" t)
(const :tag "Open overlays" open)
- (const :tag "Don't match hidden text" nil))
- :group 'isearch)
+ (const :tag "Don't match hidden text" nil)))
(defcustom isearch-hide-immediately t
"If non-nil, re-hide an invisible match right away.
@@ -156,15 +149,13 @@ This variable makes a difference when `search-invisible'
is set to `open'.
If nil then do not re-hide opened invisible text when the match moves.
Whatever the value, all opened invisible text is hidden again after exiting
the search."
- :type 'boolean
- :group 'isearch)
+ :type 'boolean)
(defcustom isearch-resume-in-command-history nil
"If non-nil, `isearch-resume' commands are added to the command history.
This allows you to resume earlier Isearch sessions through the
command history."
- :type 'boolean
- :group 'isearch)
+ :type 'boolean)
(defvar isearch-mode-hook nil
"Function(s) to call after starting up an incremental search.")
@@ -212,12 +203,10 @@ displayed in the search message.")
(defcustom search-ring-max 16
"Maximum length of search ring before oldest elements are thrown away."
- :type 'integer
- :group 'isearch)
+ :type 'integer)
(defcustom regexp-search-ring-max 16
"Maximum length of regexp search ring before oldest elements are thrown
away."
- :type 'integer
- :group 'isearch)
+ :type 'integer)
(defvar search-ring-yank-pointer nil
"Index in `search-ring' of last string reused.
@@ -229,15 +218,34 @@ It is nil if none yet.")
(defcustom search-ring-update nil
"Non-nil if advancing or retreating in the search ring should cause search.
Default value, nil, means edit the string instead."
- :type 'boolean
- :group 'isearch)
+ :type 'boolean)
+
+(autoload 'character-fold-to-regexp "character-fold")
+
+(defcustom search-default-regexp-mode nil
+ "Default mode to use when starting isearch.
+Value is nil, t, or a function.
+
+If nil, default to literal searches (note that `case-fold-search'
+and `isearch-lax-whitespace' may still be applied).\\<isearch-mode-map>
+If t, default to regexp searches (as if typing `\\[isearch-toggle-regexp]'
during
+isearch).
+
+If a function, use that function as an `isearch-regexp-function'.
+Example functions are `word-search-regexp' \(`\\[isearch-toggle-word]'),
+`isearch-symbol-regexp' \(`\\[isearch-toggle-symbol]'), and
+`character-fold-to-regexp' \(`\\[isearch-toggle-character-fold]')."
+ ;; :type is set below by `isearch-define-mode-toggle'.
+ :type '(choice (const :tag "Literal search" nil)
+ (const :tag "Regexp search" t)
+ (function :tag "Other"))
+ :version "25.1")
;;; isearch highlight customization.
(defcustom search-highlight t
"Non-nil means incremental search highlights the current match."
- :type 'boolean
- :group 'isearch)
+ :type 'boolean)
(defface isearch
'((((class color) (min-colors 88) (background light))
@@ -269,8 +277,7 @@ Default value, nil, means edit the string instead."
:foreground "grey")
(t (:inverse-video t)))
"Face for highlighting failed part in Isearch echo-area message."
- :version "23.1"
- :group 'isearch)
+ :version "23.1")
(defcustom isearch-lazy-highlight t
"Controls the lazy-highlighting during incremental search.
@@ -513,13 +520,7 @@ This is like `describe-bindings', but displays only
Isearch keys."
(put 'isearch-edit-string :advertised-binding "\M-se")
(define-key map "\M-se" 'isearch-edit-string)
- (define-key map "\M-sc" 'isearch-toggle-case-fold)
- (define-key map "\M-si" 'isearch-toggle-invisible)
- (define-key map "\M-sr" 'isearch-toggle-regexp)
- (define-key map "\M-sw" 'isearch-toggle-word)
- (define-key map "\M-s_" 'isearch-toggle-symbol)
- (define-key map "\M-s " 'isearch-toggle-lax-whitespace)
- (define-key map "\M-s'" #'isearch-toggle-character-fold)
+ ;; More toggles defined by `isearch-define-mode-toggle'.
(define-key map [?\M-%] 'isearch-query-replace)
(define-key map [?\C-\M-%] 'isearch-query-replace-regexp)
@@ -839,10 +840,6 @@ See the command `isearch-forward-symbol' for more
information."
;; isearch-forward-regexp isearch-backward-regexp)
;; "List of commands for which isearch-mode does not recursive-edit.")
-(autoload 'character-fold-to-regexp "character-fold")
-(put 'character-fold-to-regexp 'isearch-message-prefix "char-fold ")
-(defvar character-fold-search)
-
(defun isearch-mode (forward &optional regexp op-fun recursive-edit
regexp-function)
"Start Isearch minor mode.
It is called by the function `isearch-forward' and other related functions.
@@ -864,11 +861,13 @@ used to set the value of `isearch-regexp-function'."
;; Initialize global vars.
(setq isearch-forward forward
- isearch-regexp regexp
+ isearch-regexp (or regexp
+ (and (not regexp-function)
+ (eq search-default-regexp-mode t)))
isearch-regexp-function (or regexp-function
- (and character-fold-search
+ (and (functionp search-default-regexp-mode)
(not regexp)
- 'character-fold-to-regexp))
+ search-default-regexp-mode))
isearch-op-fun op-fun
isearch-last-case-fold-search isearch-case-fold-search
isearch-case-fold-search case-fold-search
@@ -1491,99 +1490,88 @@ Use `isearch-exit' to quit without signaling."
(interactive)
(isearch-repeat 'backward))
-(defun isearch-toggle-regexp ()
- "Toggle regexp searching on or off."
- ;; The status stack is left unchanged.
- (interactive)
- (setq isearch-regexp (not isearch-regexp))
- (if isearch-regexp (setq isearch-regexp-function nil))
- (setq isearch-success t isearch-adjusted t)
- (isearch-update))
-
-(defun isearch-toggle-word ()
- "Toggle word searching on or off."
- ;; The status stack is left unchanged.
- (interactive)
- (setq isearch-regexp-function
- (if (memq isearch-regexp-function '(t word-search-regexp))
- nil #'word-search-regexp))
- (when isearch-regexp-function (setq isearch-regexp nil))
- (setq isearch-success t isearch-adjusted t)
- (isearch-update))
-
-(defun isearch-toggle-symbol ()
- "Toggle symbol searching on or off."
- (interactive)
- (setq isearch-regexp-function
- (unless (eq isearch-regexp-function #'isearch-symbol-regexp)
- 'isearch-symbol-regexp))
- (when isearch-regexp-function (setq isearch-regexp nil))
- (setq isearch-success t isearch-adjusted t)
- (isearch-update))
+
+;;; Toggles for `isearch-regexp-function' and `search-default-regexp-mode'.
+(defmacro isearch-define-mode-toggle (mode key function &optional docstring
&rest body)
+ "Define a command called `isearch-toggle-MODE' and bind it to `M-s KEY'.
+The first line of the docstring is auto-generated, the remainder
+may be provided in DOCSTRING.
+If FUNCTION is a symbol, this command first toggles the value of
+`isearch-regexp-function' between nil and FUNCTION. Also set the
+`isearch-message-prefix' property of FUNCTION.
+The command then executes BODY and updates the isearch prompt."
+ (declare (indent defun))
+ (let ((command-name (intern (format "isearch-toggle-%s" mode))))
+ `(progn
+ (defun ,command-name ()
+ ,(format "Toggle %s searching on or off.%s" mode
+ (if docstring (concat "\n" docstring) ""))
+ (interactive)
+ ,@(when function
+ `((setq isearch-regexp-function
+ (unless (eq isearch-regexp-function #',function)
+ #',function))
+ (when isearch-regexp-function (setq isearch-regexp nil))))
+ ,@body
+ (setq isearch-success t isearch-adjusted t)
+ (isearch-update))
+ (define-key isearch-mode-map ,(concat "\M-s" key) #',command-name)
+ ,@(when (symbolp function)
+ `((put ',function 'isearch-message-prefix ,(format "%s " mode))
+ (cl-callf (lambda (types) (cons 'choice
+ (cons '(const :tag ,(capitalize
(format "%s search" mode)) ,function)
+ (cdr types))))
+ (get 'search-default-regexp-mode 'custom-type)))))))
+
+(isearch-define-mode-toggle word "w" word-search-regexp)
+(isearch-define-mode-toggle symbol "_" isearch-symbol-regexp)
+(isearch-define-mode-toggle character-fold "'" character-fold-to-regexp)
+(put 'character-fold-to-regexp 'isearch-message-prefix "char-fold ")
-(defun isearch-toggle-character-fold ()
- "Toggle character folding in searching on or off."
- (interactive)
- (setq isearch-regexp-function
- (unless (eq isearch-regexp-function #'character-fold-to-regexp)
- #'character-fold-to-regexp))
- (when isearch-regexp-function (setq isearch-regexp nil))
- (setq isearch-success t isearch-adjusted t)
- (isearch-update))
+(isearch-define-mode-toggle regexp "r" nil nil
+ (setq isearch-regexp (not isearch-regexp))
+ (if isearch-regexp (setq isearch-regexp-function nil)))
-(defun isearch-toggle-lax-whitespace ()
- "Toggle whitespace matching in searching on or off.
-In ordinary search, toggles the value of the variable
-`isearch-lax-whitespace'. In regexp search, toggles the
-value of the variable `isearch-regexp-lax-whitespace'."
- (interactive)
- (if isearch-regexp
- (setq isearch-regexp-lax-whitespace (not isearch-regexp-lax-whitespace))
- (setq isearch-lax-whitespace (not isearch-lax-whitespace)))
+(defun isearch--momentary-message (string)
+ "Print STRING at the end of the isearch prompt for 1 second"
(let ((message-log-max nil))
(message "%s%s [%s]"
- (isearch-message-prefix nil isearch-nonincremental)
- isearch-message
- (if (if isearch-regexp
- isearch-regexp-lax-whitespace
- isearch-lax-whitespace)
- "match spaces loosely"
- "match spaces literally")))
- (setq isearch-success t isearch-adjusted t)
- (sit-for 1)
- (isearch-update))
+ (isearch-message-prefix nil isearch-nonincremental)
+ isearch-message
+ string))
+ (sit-for 1))
-(defun isearch-toggle-case-fold ()
- "Toggle case folding in searching on or off.
-Toggles the value of the variable `isearch-case-fold-search'."
- (interactive)
- (setq isearch-case-fold-search
- (if isearch-case-fold-search nil 'yes))
- (let ((message-log-max nil))
- (message "%s%s [case %ssensitive]"
- (isearch-message-prefix nil isearch-nonincremental)
- isearch-message
- (if isearch-case-fold-search "in" "")))
- (setq isearch-success t isearch-adjusted t)
- (sit-for 1)
- (isearch-update))
-
-(defun isearch-toggle-invisible ()
- "Toggle searching in invisible text on or off.
+(isearch-define-mode-toggle lax-whitespace " " nil
+ "In ordinary search, toggles the value of the variable
+`isearch-lax-whitespace'. In regexp search, toggles the
+value of the variable `isearch-regexp-lax-whitespace'."
+ (isearch--momentary-message
+ (if (if isearch-regexp
+ (setq isearch-regexp-lax-whitespace (not
isearch-regexp-lax-whitespace))
+ (setq isearch-lax-whitespace (not isearch-lax-whitespace)))
+ "match spaces loosely"
+ "match spaces literally")))
+
+(isearch-define-mode-toggle case-fold "c" nil
+ "Toggles the value of the variable `isearch-case-fold-search'."
+ (isearch--momentary-message
+ (if (setq isearch-case-fold-search
+ (if isearch-case-fold-search nil 'yes))
+ "case insensitive"
+ "case sensitive")))
+
+(isearch-define-mode-toggle invisible "i" nil
+ "This determines whether to search inside invisible text or not.
Toggles the variable `isearch-invisible' between values
nil and a non-nil value of the option `search-invisible'
\(or `open' if `search-invisible' is nil)."
- (interactive)
- (setq isearch-invisible
- (if isearch-invisible nil (or search-invisible 'open)))
- (let ((message-log-max nil))
- (message "%s%s [match %svisible text]"
- (isearch-message-prefix nil isearch-nonincremental)
- isearch-message
- (if isearch-invisible "in" "")))
- (setq isearch-success t isearch-adjusted t)
- (sit-for 1)
- (isearch-update))
+ "match %svisible text"
+ (isearch--momentary-message
+ (if (setq isearch-invisible
+ (if isearch-invisible
+ nil (or search-invisible 'open)))
+ "match invisible text"
+ "match visible text")))
;; Word search
@@ -1782,7 +1770,6 @@ replacements from Isearch is `M-s w ... M-%'."
isearch-string
(concat "Query replace"
(isearch--describe-regexp-mode (or delimited
isearch-regexp-function) t)
- (if isearch-regexp " regexp" "")
(if backward " backward" "")
(if (and transient-mark-mode mark-active) " in region" ""))
isearch-regexp)
@@ -2532,12 +2519,19 @@ If there is no completion possible, say so and continue
searching."
"Make a string for describing REGEXP-FUNCTION.
If SPACE-BEFORE is non-nil, put a space before, instead of after,
the word mode."
+ (when (eq regexp-function t)
+ (setq regexp-function #'word-search-regexp))
(let ((description
- (cond ((and (symbolp regexp-function)
- (get regexp-function 'isearch-message-prefix))
- (get regexp-function 'isearch-message-prefix))
- (regexp-function "word ")
- (t ""))))
+ ;; Don't use a description on the default search mode.
+ (cond ((equal regexp-function search-default-regexp-mode) "")
+ (regexp-function
+ (and (symbolp regexp-function)
+ (or (get regexp-function 'isearch-message-prefix)
+ "")))
+ (isearch-regexp "regexp ")
+ ;; We're in literal mode. If the default mode is not
+ ;; literal, then describe it.
+ ((functionp search-default-regexp-mode) "literal "))))
(if space-before
;; Move space from the end to the beginning.
(replace-regexp-in-string "\\(.*\\) \\'" " \\1" description)
@@ -2573,7 +2567,6 @@ the word mode."
isearch-filter-predicate)
prefix)
(isearch--describe-regexp-mode isearch-regexp-function)
- (if isearch-regexp "regexp " "")
(cond
(multi-isearch-file-list "multi-file ")
(multi-isearch-buffer-list "multi-buffer ")
diff --git a/lisp/json.el b/lisp/json.el
index e2c7cc7..b23d12a 100644
--- a/lisp/json.el
+++ b/lisp/json.el
@@ -358,7 +358,7 @@ Please see the documentation of `json-object-type'."
(cond ((eq json-object-type 'hash-table)
(make-hash-table :test 'equal))
(t
- (list))))
+ ())))
(defun json-add-to-object (object key value)
"Add a new KEY -> VALUE association to OBJECT.
diff --git a/lisp/net/eww.el b/lisp/net/eww.el
index bda4e0c..5748e88 100644
--- a/lisp/net/eww.el
+++ b/lisp/net/eww.el
@@ -564,6 +564,15 @@ Currently this means either text/html or
application/xhtml+xml."
(delete-region (point-min) (point-max))
(insert (or source "no source"))
(goto-char (point-min))
+ ;; Decode the source and set the buffer's encoding according
+ ;; to what the HTML source specifies in its 'charset' header,
+ ;; if any.
+ (let ((cs (find-auto-coding "" (point-max))))
+ (when (consp cs)
+ (setq cs (car cs))
+ (when (coding-system-p cs)
+ (decode-coding-region (point-min) (point-max) cs)
+ (setq buffer-file-coding-system last-coding-system-used))))
(when (fboundp 'html-mode)
(html-mode))))
(view-buffer buf)))
@@ -1492,7 +1501,7 @@ If CHARSET is nil then use UTF-8."
(setq start (point)
title (plist-get bookmark :title))
(when (> (length title) width)
- (setq title (substring title 0 width)))
+ (setq title (truncate-string-to-width title width)))
(insert (format format title (plist-get bookmark :url)) "\n")
(put-text-property start (1+ start) 'eww-bookmark bookmark))
(goto-char (point-min))))
diff --git a/lisp/net/soap-client.el b/lisp/net/soap-client.el
index 509c021..264a39c 100644
--- a/lisp/net/soap-client.el
+++ b/lisp/net/soap-client.el
@@ -1,12 +1,14 @@
-;;;; soap-client.el -- Access SOAP web services from Emacs
+;;;; soap-client.el -- Access SOAP web services -*- lexical-binding: t
-*-
;; Copyright (C) 2009-2015 Free Software Foundation, Inc.
;; Author: Alexandru Harsanyi <address@hidden>
+;; Author: Thomas Fitzsimmons <address@hidden>
;; Created: December, 2009
+;; Version: 3.0.1
;; Keywords: soap, web-services, comm, hypermedia
;; Package: soap-client
-;; Homepage: http://code.google.com/p/emacs-soap-client
+;; Homepage: https://github.com/alex-hhh/emacs-soap-client
;; This file is part of GNU Emacs.
@@ -43,10 +45,14 @@
(eval-when-compile (require 'cl))
(require 'xml)
+(require 'xsd-regexp)
+(require 'rng-xsd)
+(require 'rng-dt)
(require 'warnings)
(require 'url)
(require 'url-http)
(require 'url-util)
+(require 'url-vars)
(require 'mm-decode)
(defsubst soap-warning (message &rest args)
@@ -74,13 +80,17 @@
("wsdlsoap" . "http://schemas.xmlsoap.org/wsdl/soap/";)
("xsd" . "http://www.w3.org/2001/XMLSchema";)
("xsi" . "http://www.w3.org/2001/XMLSchema-instance";)
+ ("wsa" . "http://www.w3.org/2005/08/addressing";)
+ ("wsaw" . "http://www.w3.org/2006/05/addressing/wsdl";)
("soap" . "http://schemas.xmlsoap.org/soap/envelope/";)
("soap12" . "http://schemas.xmlsoap.org/wsdl/soap12/";)
("http" . "http://schemas.xmlsoap.org/wsdl/http/";)
- ("mime" . "http://schemas.xmlsoap.org/wsdl/mime/";))
+ ("mime" . "http://schemas.xmlsoap.org/wsdl/mime/";)
+ ("xml" . "http://www.w3.org/XML/1998/namespace";))
"A list of well known xml namespaces and their aliases.")
-(defvar soap-local-xmlns nil
+(defvar soap-local-xmlns
+ '(("xml" . "http://www.w3.org/XML/1998/namespace";))
"A list of local namespace aliases.
This is a dynamically bound variable, controlled by
`soap-with-local-xmlns'.")
@@ -98,6 +108,10 @@ are fully qualified for a different namespace. This is a
dynamically bound variable, controlled by
`soap-with-local-xmlns'")
+(defvar soap-current-wsdl nil
+ "The current WSDL document used when decoding the SOAP response.
+This is a dynamically bound variable.")
+
(defun soap-wk2l (well-known-name)
"Return local variant of WELL-KNOWN-NAME.
This is done by looking up the namespace in the
@@ -106,24 +120,24 @@ the local name based on the current local translation
table
`soap-local-xmlns'. See also `soap-with-local-xmlns'."
(let ((wk-name-1 (if (symbolp well-known-name)
(symbol-name well-known-name)
- well-known-name)))
+ well-known-name)))
(cond
- ((string-match "^\\(.*\\):\\(.*\\)$" wk-name-1)
- (let ((ns (match-string 1 wk-name-1))
- (name (match-string 2 wk-name-1)))
- (let ((namespace (cdr (assoc ns soap-well-known-xmlns))))
- (cond ((equal namespace soap-default-xmlns)
- ;; Name is unqualified in the default namespace
- (if (symbolp well-known-name)
- (intern name)
- name))
- (t
- (let* ((local-ns (car (rassoc namespace soap-local-xmlns)))
- (local-name (concat local-ns ":" name)))
- (if (symbolp well-known-name)
- (intern local-name)
- local-name)))))))
- (t well-known-name))))
+ ((string-match "^\\(.*\\):\\(.*\\)$" wk-name-1)
+ (let ((ns (match-string 1 wk-name-1))
+ (name (match-string 2 wk-name-1)))
+ (let ((namespace (cdr (assoc ns soap-well-known-xmlns))))
+ (cond ((equal namespace soap-default-xmlns)
+ ;; Name is unqualified in the default namespace
+ (if (symbolp well-known-name)
+ (intern name)
+ name))
+ (t
+ (let* ((local-ns (car (rassoc namespace soap-local-xmlns)))
+ (local-name (concat local-ns ":" name)))
+ (if (symbolp well-known-name)
+ (intern local-name)
+ local-name)))))))
+ (t well-known-name))))
(defun soap-l2wk (local-name)
"Convert LOCAL-NAME into a well known name.
@@ -134,40 +148,37 @@ used in the name.
nil is returned if there is no well-known namespace for the
namespace of LOCAL-NAME."
(let ((l-name-1 (if (symbolp local-name)
- (symbol-name local-name)
- local-name))
+ (symbol-name local-name)
+ local-name))
namespace name)
(cond
- ((string-match "^\\(.*\\):\\(.*\\)$" l-name-1)
- (setq name (match-string 2 l-name-1))
- (let ((ns (match-string 1 l-name-1)))
- (setq namespace (cdr (assoc ns soap-local-xmlns)))
- (unless namespace
- (error "Soap-l2wk(%s): no namespace for alias %s" local-name ns))))
- (t
- (setq name l-name-1)
- (setq namespace soap-default-xmlns)))
+ ((string-match "^\\(.*\\):\\(.*\\)$" l-name-1)
+ (setq name (match-string 2 l-name-1))
+ (let ((ns (match-string 1 l-name-1)))
+ (setq namespace (cdr (assoc ns soap-local-xmlns)))
+ (unless namespace
+ (error "Soap-l2wk(%s): no namespace for alias %s" local-name ns))))
+ (t
+ (setq name l-name-1)
+ (setq namespace soap-default-xmlns)))
(if namespace
(let ((well-known-ns (car (rassoc namespace soap-well-known-xmlns))))
(if well-known-ns
(let ((well-known-name (concat well-known-ns ":" name)))
- (if (symbol-name local-name)
+ (if (symbolp local-name)
(intern well-known-name)
- well-known-name))
- (progn
- ;; (soap-warning "soap-l2wk(%s): namespace %s has no
well-known tag"
- ;; local-name namespace)
- nil)))
- ;; if no namespace is defined, just return the unqualified name
- name)))
+ well-known-name))
+ nil))
+ ;; if no namespace is defined, just return the unqualified name
+ name)))
(defun soap-l2fq (local-name &optional use-tns)
"Convert LOCAL-NAME into a fully qualified name.
A fully qualified name is a cons of the namespace name and the
name of the element itself. For example \"xsd:string\" is
-converted to \(\"http://www.w3.org/2001/XMLSchema\"; . \"string\").
+converted to (\"http://www.w3.org/2001/XMLSchema\"; . \"string\").
The USE-TNS argument specifies what to do when LOCAL-NAME has no
namespace tag. If USE-TNS is non-nil, the `soap-target-xmlns'
@@ -178,19 +189,27 @@ This is needed because different parts of a WSDL document
can use
different namespace aliases for the same element."
(let ((local-name-1 (if (symbolp local-name)
(symbol-name local-name)
- local-name)))
+ local-name)))
(cond ((string-match "^\\(.*\\):\\(.*\\)$" local-name-1)
(let ((ns (match-string 1 local-name-1))
(name (match-string 2 local-name-1)))
(let ((namespace (cdr (assoc ns soap-local-xmlns))))
(if namespace
(cons namespace name)
- (error "Soap-l2fq(%s): unknown alias %s" local-name ns)))))
+ (error "Soap-l2fq(%s): unknown alias %s" local-name ns)))))
(t
(cons (if use-tns
soap-target-xmlns
- soap-default-xmlns)
- local-name)))))
+ soap-default-xmlns)
+ local-name-1)))))
+
+(defun soap-name-p (name)
+ "Return true if NAME is a valid name for XMLSchema types.
+A valid name is either a string or a cons of (NAMESPACE . NAME)."
+ (or (stringp name)
+ (and (consp name)
+ (stringp (car name))
+ (stringp (cdr name)))))
(defun soap-extract-xmlns (node &optional xmlns-table)
"Return a namespace alias table for NODE by extending XMLNS-TABLE."
@@ -211,16 +230,10 @@ different namespace aliases for the same element."
;; the target namespace.
(unless (equal target-ns (cdr tns))
(soap-warning
- "soap-extract-xmlns(%s): tns alias and targetNamespace mismatch"
- (xml-node-name node))))
+ "soap-extract-xmlns(%s): tns alias and targetNamespace
mismatch"
+ (xml-node-name node))))
((and tns (not target-ns))
- (setq target-ns (cdr tns)))
- ((and (not tns) target-ns)
- ;; a tns alias was not defined in this node. See if the node has
- ;; a "targetNamespace" attribute and add an alias to this. Note
- ;; that we might override an existing tns alias in XMLNS-TABLE,
- ;; but that is intended.
- (push (cons "tns" target-ns) xmlns))))
+ (setq target-ns (cdr tns)))))
(list default-ns target-ns (append xmlns xmlns-table))))
@@ -250,13 +263,21 @@ namespace tag."
(when (and (consp c)
(soap-with-local-xmlns c
;; We use `ignore-errors' here because we want to silently
- ;; skip nodes for which we cannot convert them to a
- ;; well-known name.
+ ;; skip nodes when we cannot convert them to a well-known
+ ;; name.
(eq (ignore-errors (soap-l2wk (xml-node-name c)))
- child-name)))
+ child-name)))
(push c result)))
(nreverse result)))
+(defun soap-xml-node-find-matching-child (node set)
+ "Return the first child of NODE whose name is a member of SET."
+ (catch 'found
+ (dolist (child (xml-node-children node))
+ (when (and (consp child)
+ (memq (soap-l2wk (xml-node-name child)) set))
+ (throw 'found child)))))
+
(defun soap-xml-get-attribute-or-nil1 (node attribute)
"Return the NODE's ATTRIBUTE, or nil if it does not exist.
This is the same as `xml-get-attribute-or-nil', but ATTRIBUTE can
@@ -287,8 +308,13 @@ be tagged with a namespace tag."
"Return a fully qualified name for ELEMENT.
A fq name is the concatenation of the namespace tag and the
element name."
- (concat (soap-element-namespace-tag element)
- ":" (soap-element-name element)))
+ (cond ((soap-element-namespace-tag element)
+ (concat (soap-element-namespace-tag element)
+ ":" (soap-element-name element)))
+ ((soap-element-name element)
+ (soap-element-name element))
+ (t
+ "*unnamed*")))
;; a namespace link stores an alias for an object in once namespace to a
;; "target" object possibly in a different namespace
@@ -311,11 +337,8 @@ discriminant predicate to `soap-namespace-get'"
(let ((name (soap-element-name element)))
(push element (gethash name (soap-namespace-elements ns)))))
-(defun soap-namespace-put-link (name target ns &optional replace)
+(defun soap-namespace-put-link (name target ns)
"Store a link from NAME to TARGET in NS.
-An error will be signaled if an element by the same name is
-already present in NS, unless REPLACE is non nil.
-
TARGET can be either a SOAP-ELEMENT or a string denoting an
element name into another namespace.
@@ -357,34 +380,1563 @@ binding) but the same name."
((= (length elements) 1) (car elements))
((> (length elements) 1)
(error
- "Soap-namespace-get(%s): multiple elements, discriminant needed"
- name))
+ "Soap-namespace-get(%s): multiple elements, discriminant needed"
+ name))
(t
nil))))
-;;;; WSDL documents
-;;;;; WSDL document elements
+;;;; XML Schema
-(defstruct (soap-basic-type (:include soap-element))
- kind ; a symbol of: string, dateTime, long, int
- )
+;; SOAP WSDL documents use XML Schema to define the types that are part of the
+;; message exchange. We include here an XML schema model with a parser and
+;; serializer/deserialiser.
-(defstruct (soap-simple-type (:include soap-basic-type))
- enumeration)
+(defstruct (soap-xs-type (:include soap-element))
+ id
+ attributes
+ attribute-groups)
-(defstruct soap-sequence-element
- name type nillable? multiple?)
+;;;;; soap-xs-basic-type
-(defstruct (soap-sequence-type (:include soap-element))
- parent ; OPTIONAL WSDL-TYPE name
- elements ; LIST of SOAP-SEQUENCE-ELEMENT
+(defstruct (soap-xs-basic-type (:include soap-xs-type))
+ ;; Basic types are "built in" and we know how to handle them directly.
+ ;; Other type definitions reference basic types, so we need to create them
+ ;; in a namespace (see `soap-make-xs-basic-types')
+
+ ;; a symbol of: string, dateTime, long, int, etc
+ kind
)
-(defstruct (soap-array-type (:include soap-element))
- element-type ; WSDL-TYPE of the array elements
+(defun soap-make-xs-basic-types (namespace-name &optional namespace-tag)
+ "Construct NAMESPACE-NAME containing the XMLSchema basic types.
+An optional NAMESPACE-TAG can also be specified."
+ (let ((ns (make-soap-namespace :name namespace-name)))
+ (dolist (type '("string" "language" "ID" "IDREF"
+ "dateTime" "time" "date" "boolean"
+ "gYearMonth" "gYear" "gMonthDay" "gDay" "gMonth"
+ "long" "short" "int" "integer" "nonNegativeInteger"
+ "unsignedLong" "unsignedShort" "unsignedInt"
+ "decimal" "duration"
+ "byte" "unsignedByte"
+ "float" "double"
+ "base64Binary" "anyType" "anyURI" "QName" "Array"
"byte[]"))
+ (soap-namespace-put
+ (make-soap-xs-basic-type :name type
+ :namespace-tag namespace-tag
+ :kind (intern type))
+ ns))
+ ns))
+
+(defun soap-encode-xs-basic-type-attributes (value type)
+ "Encode the XML attributes for VALUE according to TYPE.
+The xsi:type and an optional xsi:nil attributes are added. The
+attributes are inserted in the current buffer at the current
+position.
+
+This is a specialization of `soap-encode-attributes' for
+`soap-xs-basic-type' objects."
+ (let ((xsi-type (soap-element-fq-name type))
+ (basic-type (soap-xs-basic-type-kind type)))
+ ;; try to classify the type based on the value type and use that type when
+ ;; encoding
+ (when (eq basic-type 'anyType)
+ (cond ((stringp value)
+ (setq xsi-type "xsd:string" basic-type 'string))
+ ((integerp value)
+ (setq xsi-type "xsd:int" basic-type 'int))
+ ((memq value '(t nil))
+ (setq xsi-type "xsd:boolean" basic-type 'boolean))
+ (t
+ (error "Cannot classify anyType value"))))
+
+ (insert " xsi:type=\"" xsi-type "\"")
+ ;; We have some ambiguity here, as a nil value represents "false" when the
+ ;; type is boolean, we will never have a "nil" boolean type...
+ (unless (or value (eq basic-type 'boolean))
+ (insert " xsi:nil=\"true\""))))
+
+(defun soap-encode-xs-basic-type (value type)
+ "Encode the VALUE according to TYPE.
+The data is inserted in the current buffer at the current
+position.
+
+This is a specialization of `soap-encode-value' for
+`soap-xs-basic-type' objects."
+ (let ((kind (soap-xs-basic-type-kind type)))
+
+ (when (eq kind 'anyType)
+ (cond ((stringp value)
+ (setq kind 'string))
+ ((integerp value)
+ (setq kind 'int))
+ ((memq value '(t nil))
+ (setq kind 'boolean))
+ (t
+ (error "Cannot classify anyType value"))))
+
+ ;; NOTE: a nil value is not encoded, as an xsi:nil="true" attribute was
+ ;; encoded for it. However, we have some ambiguity here, as a nil value
+ ;; also represents "false" when the type is boolean...
+
+ (when (or value (eq kind 'boolean))
+ (let ((value-string
+ (case kind
+ ((string anyURI QName ID IDREF language)
+ (unless (stringp value)
+ (error "Not a string value: %s" value))
+ (url-insert-entities-in-string value))
+ ((dateTime time date gYearMonth gYear gMonthDay gDay gMonth)
+ (cond ((consp value)
+ ;; Value is a (current-time) style value,
+ ;; convert to the ISO 8601-inspired XSD
+ ;; string format in UTC.
+ (format-time-string
+ (concat
+ (ecase kind
+ (dateTime "%Y-%m-%dT%H:%M:%S")
+ (time "%H:%M:%S")
+ (date "%Y-%m-%d")
+ (gYearMonth "%Y-%m")
+ (gYear "%Y")
+ (gMonthDay "--%m-%d")
+ (gDay "---%d")
+ (gMonth "--%m"))
+ ;; Internal time is always in UTC.
+ "Z")
+ value t))
+ ((stringp value)
+ ;; Value is a string in the ISO 8601-inspired XSD
+ ;; format. Validate it.
+ (soap-decode-date-time value kind)
+ (url-insert-entities-in-string value))
+ (t
+ (error "Invalid date-time format"))))
+ (boolean
+ (unless (memq value '(t nil))
+ (error "Not a boolean value"))
+ (if value "true" "false"))
+
+ ((long short int integer byte unsignedInt unsignedLong
+ unsignedShort nonNegativeInteger decimal duration)
+ (unless (integerp value)
+ (error "Not an integer value"))
+ (when (and (memq kind '(unsignedInt unsignedLong
+ unsignedShort
+ nonNegativeInteger))
+ (< value 0))
+ (error "Not a positive integer"))
+ (number-to-string value))
+
+ ((float double)
+ (unless (numberp value)
+ (error "Not a number"))
+ (number-to-string value))
+
+ (base64Binary
+ (unless (stringp value)
+ (error "Not a string value for base64Binary"))
+ (base64-encode-string value))
+
+ (otherwise
+ (error "Don't know how to encode %s for type %s"
+ value (soap-element-fq-name type))))))
+ (soap-validate-xs-basic-type value-string type)
+ (insert value-string)))))
+
+;; Inspired by rng-xsd-convert-date-time.
+(defun soap-decode-date-time (date-time-string datatype)
+ "Decode DATE-TIME-STRING as DATATYPE.
+DATE-TIME-STRING should be in ISO 8601 basic or extended format.
+DATATYPE is one of dateTime, time, date, gYearMonth, gYear,
+gMonthDay, gDay or gMonth.
+
+Return a list in a format (SEC MINUTE HOUR DAY MONTH YEAR
+SEC-FRACTION DATATYPE ZONE). This format is meant to be similar
+to that returned by `decode-time' (and compatible with
+`encode-time'). The differences are the DOW (day-of-week) field
+is replaced with SEC-FRACTION, a float representing the
+fractional seconds, and the DST (daylight savings time) field is
+replaced with DATATYPE, a symbol representing the XSD primitive
+datatype. This symbol can be used to determine which fields
+apply and which don't when it's not already clear from context.
+For example a datatype of 'time means the year, month and day
+fields should be ignored.
+
+This function will throw an error if DATE-TIME-STRING represents
+a leap second, since the XML Schema 1.1 standard explicitly
+disallows them."
+ (let* ((datetime-regexp (cadr (get datatype 'rng-xsd-convert)))
+ (year-sign (progn
+ (string-match datetime-regexp date-time-string)
+ (match-string 1 date-time-string)))
+ (year (match-string 2 date-time-string))
+ (month (match-string 3 date-time-string))
+ (day (match-string 4 date-time-string))
+ (hour (match-string 5 date-time-string))
+ (minute (match-string 6 date-time-string))
+ (second (match-string 7 date-time-string))
+ (second-fraction (match-string 8 date-time-string))
+ (has-time-zone (match-string 9 date-time-string))
+ (time-zone-sign (match-string 10 date-time-string))
+ (time-zone-hour (match-string 11 date-time-string))
+ (time-zone-minute (match-string 12 date-time-string)))
+ (setq year-sign (if year-sign -1 1))
+ (setq year
+ (if year
+ (* year-sign
+ (string-to-number year))
+ ;; By defaulting to the epoch date, a time value can be treated as
+ ;; a relative number of seconds.
+ 1970))
+ (setq month
+ (if month (string-to-number month) 1))
+ (setq day
+ (if day (string-to-number day) 1))
+ (setq hour
+ (if hour (string-to-number hour) 0))
+ (setq minute
+ (if minute (string-to-number minute) 0))
+ (setq second
+ (if second (string-to-number second) 0))
+ (setq second-fraction
+ (if second-fraction
+ (float (string-to-number second-fraction))
+ 0.0))
+ (setq has-time-zone (and has-time-zone t))
+ (setq time-zone-sign
+ (if (equal time-zone-sign "-") -1 1))
+ (setq time-zone-hour
+ (if time-zone-hour (string-to-number time-zone-hour) 0))
+ (setq time-zone-minute
+ (if time-zone-minute (string-to-number time-zone-minute) 0))
+ (unless (and
+ ;; XSD does not allow year 0.
+ (> year 0)
+ (>= month 1) (<= month 12)
+ (>= day 1) (<= day (rng-xsd-days-in-month year month))
+ (>= hour 0) (<= hour 23)
+ (>= minute 0) (<= minute 59)
+ ;; 60 represents a leap second, but leap seconds are explicitly
+ ;; disallowed by the XML Schema 1.1 specification. This agrees
+ ;; with typical Emacs installations, which don't count leap
+ ;; seconds in time values.
+ (>= second 0) (<= second 59)
+ (>= time-zone-hour 0)
+ (<= time-zone-hour 23)
+ (>= time-zone-minute 0)
+ (<= time-zone-minute 59))
+ (error "Invalid or unsupported time: %s" date-time-string))
+ ;; Return a value in a format similar to that returned by decode-time, and
+ ;; suitable for (apply 'encode-time ...).
+ (list second minute hour day month year second-fraction datatype
+ (if has-time-zone
+ (* (rng-xsd-time-to-seconds
+ time-zone-hour
+ time-zone-minute
+ 0)
+ time-zone-sign)
+ ;; UTC.
+ 0))))
+
+(defun soap-decode-xs-basic-type (type node)
+ "Use TYPE, a `soap-xs-basic-type', to decode the contents of NODE.
+A LISP value is returned based on the contents of NODE and the
+type-info stored in TYPE.
+
+This is a specialization of `soap-decode-type' for
+`soap-xs-basic-type' objects."
+ (let ((contents (xml-node-children node))
+ (kind (soap-xs-basic-type-kind type))
+ (attributes (xml-node-attributes node))
+ (validate-type type)
+ (is-nil nil))
+
+ (dolist (attribute attributes)
+ (let ((attribute-type (soap-l2fq (car attribute)))
+ (attribute-value (cdr attribute)))
+ ;; xsi:type can override an element's expected type.
+ (when (equal attribute-type (soap-l2fq "xsi:type"))
+ (setq validate-type
+ (soap-wsdl-get attribute-value soap-current-wsdl)))
+ ;; xsi:nil can specify that an element is nil in which case we don't
+ ;; validate it.
+ (when (equal attribute-type (soap-l2fq "xsi:nil"))
+ (setq is-nil (string= (downcase attribute-value) "true")))))
+
+ (unless is-nil
+ ;; For validation purposes, when xml-node-children returns nil, treat it
+ ;; as the empty string.
+ (soap-validate-xs-basic-type (car (or contents (list "")))
validate-type))
+
+ (if (null contents)
+ nil
+ (ecase kind
+ ((string anyURI QName ID IDREF language) (car contents))
+ ((dateTime time date gYearMonth gYear gMonthDay gDay gMonth)
+ (car contents))
+ ((long short int integer
+ unsignedInt unsignedLong unsignedShort nonNegativeInteger
+ decimal byte float double duration)
+ (string-to-number (car contents)))
+ (boolean (string= (downcase (car contents)) "true"))
+ (base64Binary (base64-decode-string (car contents)))
+ (anyType (soap-decode-any-type node))
+ (Array (soap-decode-array node))))))
+
+;; Register methods for `soap-xs-basic-type'
+(let ((tag (aref (make-soap-xs-basic-type) 0)))
+ (put tag 'soap-attribute-encoder #'soap-encode-xs-basic-type-attributes)
+ (put tag 'soap-encoder #'soap-encode-xs-basic-type)
+ (put tag 'soap-decoder #'soap-decode-xs-basic-type))
+
+;;;;; soap-xs-element
+
+(defstruct (soap-xs-element (:include soap-element))
+ ;; NOTE: we don't support exact number of occurrences via minOccurs,
+ ;; maxOccurs. Instead we support optional? and multiple?
+
+ id
+ type^ ; note: use soap-xs-element-type to retrieve this member
+ optional?
+ multiple?
+ reference
+ substitution-group
+ ;; contains a list of elements who point to this one via their
+ ;; substitution-group slot
+ alternatives
+ is-group)
+
+(defun soap-xs-element-type (element)
+ "Retrieve the type of ELEMENT.
+This is normally stored in the TYPE^ slot, but if this element
+contains a reference, we retrive the type of the reference."
+ (if (soap-xs-element-reference element)
+ (soap-xs-element-type (soap-xs-element-reference element))
+ (soap-xs-element-type^ element)))
+
+(defun soap-node-optional (node)
+ "Return t if NODE specifies an optional element."
+ (or (equal (xml-get-attribute-or-nil node 'nillable) "true")
+ (let ((e (xml-get-attribute-or-nil node 'minOccurs)))
+ (and e (equal e "0")))))
+
+(defun soap-node-multiple (node)
+ "Return t if NODE permits multiple elements."
+ (let* ((e (xml-get-attribute-or-nil node 'maxOccurs)))
+ (and e (not (equal e "1")))))
+
+(defun soap-xs-parse-element (node)
+ "Construct a `soap-xs-element' from NODE."
+ (let ((name (xml-get-attribute-or-nil node 'name))
+ (id (xml-get-attribute-or-nil node 'id))
+ (type (xml-get-attribute-or-nil node 'type))
+ (optional? (soap-node-optional node))
+ (multiple? (soap-node-multiple node))
+ (ref (xml-get-attribute-or-nil node 'ref))
+ (substitution-group (xml-get-attribute-or-nil node 'substitutionGroup))
+ (node-name (soap-l2wk (xml-node-name node))))
+ (assert (memq node-name '(xsd:element xsd:group))
+ "expecting xsd:element or xsd:group, got %s" node-name)
+
+ (when type
+ (setq type (soap-l2fq type 'tns)))
+
+ (when ref
+ (setq ref (soap-l2fq ref 'tns)))
+
+ (when substitution-group
+ (setq substitution-group (soap-l2fq substitution-group 'tns)))
+
+ (unless (or ref type)
+ ;; no type specified and this is not a reference. Must be a type
+ ;; defined within this node.
+ (let ((simple-type (soap-xml-get-children1 node 'xsd:simpleType)))
+ (if simple-type
+ (setq type (soap-xs-parse-simple-type (car simple-type)))
+ ;; else
+ (let ((complex-type (soap-xml-get-children1 node 'xsd:complexType)))
+ (if complex-type
+ (setq type (soap-xs-parse-complex-type (car complex-type)))
+ ;; else
+ (error "Soap-xs-parse-element: missing type or ref"))))))
+
+ (make-soap-xs-element :name name
+ ;; Use the full namespace name for now, we will
+ ;; convert it to a nstag in
+ ;; `soap-resolve-references-for-xs-element'
+ :namespace-tag soap-target-xmlns
+ :id id :type^ type
+ :optional? optional? :multiple? multiple?
+ :reference ref
+ :substitution-group substitution-group
+ :is-group (eq node-name 'xsd:group))))
+
+(defun soap-resolve-references-for-xs-element (element wsdl)
+ "Replace names in ELEMENT with the referenced objects in the WSDL.
+This is a specialization of `soap-resolve-references' for
+`soap-xs-element' objects.
+
+See also `soap-wsdl-resolve-references'."
+
+ (let ((namespace (soap-element-namespace-tag element)))
+ (when namespace
+ (let ((nstag (car (rassoc namespace (soap-wsdl-alias-table wsdl)))))
+ (when nstag
+ (setf (soap-element-namespace-tag element) nstag)))))
+
+ (let ((type (soap-xs-element-type^ element)))
+ (cond ((soap-name-p type)
+ (setf (soap-xs-element-type^ element)
+ (soap-wsdl-get type wsdl 'soap-xs-type-p)))
+ ((soap-xs-type-p type)
+ ;; an inline defined type, this will not be reached from anywhere
+ ;; else, so we must resolve references now.
+ (soap-resolve-references type wsdl))))
+ (let ((reference (soap-xs-element-reference element)))
+ (when (and (soap-name-p reference)
+ ;; xsd:group reference nodes will be converted to inline types
+ ;; by soap-resolve-references-for-xs-complex-type, so skip them
+ ;; here.
+ (not (soap-xs-element-is-group element)))
+ (setf (soap-xs-element-reference element)
+ (soap-wsdl-get reference wsdl 'soap-xs-element-p))))
+
+ (let ((subst (soap-xs-element-substitution-group element)))
+ (when (soap-name-p subst)
+ (let ((target (soap-wsdl-get subst wsdl)))
+ (if target
+ (push element (soap-xs-element-alternatives target))
+ (soap-warning "No target found for substitution-group" subst))))))
+
+(defun soap-encode-xs-element-attributes (value element)
+ "Encode the XML attributes for VALUE according to ELEMENT.
+Currently no attributes are needed.
+
+This is a specialization of `soap-encode-attributes' for
+`soap-xs-basic-type' objects."
+ ;; Use the variables to suppress checkdoc and compiler warnings.
+ (list value element)
+ nil)
+
+(defun soap-should-encode-value-for-xs-element (value element)
+ "Return t if VALUE should be encoded for ELEMENT, nil otherwise."
+ (cond
+ ;; if value is not nil, attempt to encode it
+ (value)
+
+ ;; value is nil, but the element's type is a boolean, so nil in this case
+ ;; means "false". We need to encode it.
+ ((let ((type (soap-xs-element-type element)))
+ (and (soap-xs-basic-type-p type)
+ (eq (soap-xs-basic-type-kind type) 'boolean))))
+
+ ;; This is not an optional element. Force encoding it (although this
+ ;; might fail at the validation step, but this is what we intend.
+
+ ;; value is nil, but the element's type has some attributes which supply a
+ ;; default value. We need to encode it.
+
+ ((let ((type (soap-xs-element-type element)))
+ (catch 'found
+ (dolist (a (soap-xs-type-attributes type))
+ (when (soap-xs-attribute-default a)
+ (throw 'found t))))))
+
+ ;; otherwise, we don't need to encode it
+ (t nil)))
+
+(defun soap-type-is-array? (type)
+ "Return t if TYPE defines an ARRAY."
+ (and (soap-xs-complex-type-p type)
+ (eq (soap-xs-complex-type-indicator type) 'array)))
+
+(defvar soap-encoded-namespaces nil
+ "A list of namespace tags used during encoding a message.
+This list is populated by `soap-encode-value' and used by
+`soap-create-envelope' to add aliases for these namespace to the
+XML request.
+
+This variable is dynamically bound in `soap-create-envelope'.")
+
+(defun soap-encode-xs-element (value element)
+ "Encode the VALUE according to ELEMENT.
+The data is inserted in the current buffer at the current
+position.
+
+This is a specialization of `soap-encode-value' for
+`soap-xs-basic-type' objects."
+ (let ((fq-name (soap-element-fq-name element))
+ (type (soap-xs-element-type element)))
+ ;; Only encode the element if it has a name. NOTE: soap-element-fq-name
+ ;; will return *unnamed* for such elements
+ (if (soap-element-name element)
+ ;; Don't encode this element if value is nil. However, even if value
+ ;; is nil we still want to encode this element if it has any attributes
+ ;; with default values.
+ (when (soap-should-encode-value-for-xs-element value element)
+ (progn
+ (insert "<" fq-name)
+ (soap-encode-attributes value type)
+ ;; If value is nil and type is boolean encode the value as "false".
+ ;; Otherwise don't encode the value.
+ (if (or value (and (soap-xs-basic-type-p type)
+ (eq (soap-xs-basic-type-kind type) 'boolean)))
+ (progn (insert ">")
+ ;; ARRAY's need special treatment, as each element of
+ ;; the array is encoded with the same tag as the
+ ;; current element...
+ (if (soap-type-is-array? type)
+ (let ((new-element (copy-soap-xs-element element)))
+ (when (soap-element-namespace-tag type)
+ (add-to-list 'soap-encoded-namespaces
+ (soap-element-namespace-tag type)))
+ (setf (soap-xs-element-type^ new-element)
+ (soap-xs-complex-type-base type))
+ (loop for i below (length value)
+ do (progn
+ (soap-encode-xs-element (aref value i)
new-element)
+ )))
+ (soap-encode-value value type))
+ (insert "</" fq-name ">\n"))
+ ;; else
+ (insert "/>\n"))))
+ (when (soap-should-encode-value-for-xs-element value element)
+ (soap-encode-value value type)))))
+
+(defun soap-decode-xs-element (element node)
+ "Use ELEMENT, a `soap-xs-element', to decode the contents of NODE.
+A LISP value is returned based on the contents of NODE and the
+type-info stored in ELEMENT.
+
+This is a specialization of `soap-decode-type' for
+`soap-xs-basic-type' objects."
+ (let ((type (soap-xs-element-type element)))
+ (soap-decode-type type node)))
+
+;; Register methods for `soap-xs-element'
+(let ((tag (aref (make-soap-xs-element) 0)))
+ (put tag 'soap-resolve-references #'soap-resolve-references-for-xs-element)
+ (put tag 'soap-attribute-encoder #'soap-encode-xs-element-attributes)
+ (put tag 'soap-encoder #'soap-encode-xs-element)
+ (put tag 'soap-decoder #'soap-decode-xs-element))
+
+;;;;; soap-xs-attribute
+
+(defstruct (soap-xs-attribute (:include soap-element))
+ type ; a simple type or basic type
+ default ; the default value, if any
+ reference)
+
+(defstruct (soap-xs-attribute-group (:include soap-xs-type))
+ reference)
+
+(defun soap-xs-parse-attribute (node)
+ "Construct a `soap-xs-attribute' from NODE."
+ (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:attribute)
+ "expecting xsd:attribute, got %s" (soap-l2wk (xml-node-name node)))
+ (let* ((name (xml-get-attribute-or-nil node 'name))
+ (type (soap-l2fq (xml-get-attribute-or-nil node 'type)))
+ (default (xml-get-attribute-or-nil node 'fixed))
+ (attribute (xml-get-attribute-or-nil node 'ref))
+ (ref (when attribute (soap-l2fq attribute))))
+ (unless (or type ref)
+ (setq type (soap-xs-parse-simple-type
+ (soap-xml-node-find-matching-child
+ node '(xsd:restriction xsd:list xsd:union)))))
+ (make-soap-xs-attribute
+ :name name :type type :default default :reference ref)))
+
+(defun soap-xs-parse-attribute-group (node)
+ "Construct a `soap-xs-attribute-group' from NODE."
+ (let ((node-name (soap-l2wk (xml-node-name node))))
+ (assert (eq node-name 'xsd:attributeGroup)
+ "expecting xsd:attributeGroup, got %s" node-name)
+ (let ((name (xml-get-attribute-or-nil node 'name))
+ (id (xml-get-attribute-or-nil node 'id))
+ (ref (xml-get-attribute-or-nil node 'ref))
+ attribute-group)
+ (when (and name ref)
+ (soap-warning "name and ref set for attribute group %s" node-name))
+ (setq attribute-group
+ (make-soap-xs-attribute-group :id id
+ :name name
+ :reference (and ref (soap-l2fq
ref))))
+ (when (not ref)
+ (dolist (child (xml-node-children node))
+ ;; Ignore whitespace.
+ (unless (stringp child)
+ ;; Ignore optional annotation.
+ ;; Ignore anyAttribute nodes.
+ (case (soap-l2wk (xml-node-name child))
+ (xsd:attribute
+ (push (soap-xs-parse-attribute child)
+ (soap-xs-type-attributes attribute-group)))
+ (xsd:attributeGroup
+ (push (soap-xs-parse-attribute-group child)
+ (soap-xs-attribute-group-attribute-groups
+ attribute-group)))))))
+ attribute-group)))
+
+(defun soap-resolve-references-for-xs-attribute (attribute wsdl)
+ "Replace names in ATTRIBUTE with the referenced objects in the WSDL.
+This is a specialization of `soap-resolve-references' for
+`soap-xs-attribute' objects.
+
+See also `soap-wsdl-resolve-references'."
+ (let* ((type (soap-xs-attribute-type attribute))
+ (reference (soap-xs-attribute-reference attribute))
+ (predicate 'soap-xs-element-p)
+ (xml-reference
+ (and (soap-name-p reference)
+ (equal (car reference)
"http://www.w3.org/XML/1998/namespace";))))
+ (cond (xml-reference
+ ;; Convert references to attributes defined by the XML
+ ;; schema (xml:base, xml:lang, xml:space and xml:id) to
+ ;; xsd:string, to avoid needing to bundle and parse
+ ;; xml.xsd.
+ (setq reference '("http://www.w3.org/2001/XMLSchema"; . "string"))
+ (setq predicate 'soap-xs-basic-type-p))
+ ((soap-name-p type)
+ (setf (soap-xs-attribute-type attribute)
+ (soap-wsdl-get type wsdl
+ (lambda (type)
+ (or (soap-xs-basic-type-p type)
+ (soap-xs-simple-type-p type))))))
+ ((soap-xs-type-p type)
+ ;; an inline defined type, this will not be reached from anywhere
+ ;; else, so we must resolve references now.
+ (soap-resolve-references type wsdl)))
+ (when (soap-name-p reference)
+ (setf (soap-xs-attribute-reference attribute)
+ (soap-wsdl-get reference wsdl predicate)))))
+
+(put (aref (make-soap-xs-attribute) 0)
+ 'soap-resolve-references #'soap-resolve-references-for-xs-attribute)
+
+(defun soap-resolve-references-for-xs-attribute-group (attribute-group wsdl)
+ "Set slots in ATTRIBUTE-GROUP to the referenced objects in the WSDL.
+This is a specialization of `soap-resolve-references' for
+`soap-xs-attribute-group' objects.
+
+See also `soap-wsdl-resolve-references'."
+ (let ((reference (soap-xs-attribute-group-reference attribute-group)))
+ (when (soap-name-p reference)
+ (let ((resolved (soap-wsdl-get reference wsdl
+ 'soap-xs-attribute-group-p)))
+ (dolist (attribute (soap-xs-attribute-group-attributes resolved))
+ (soap-resolve-references attribute wsdl))
+ (setf (soap-xs-attribute-group-name attribute-group)
+ (soap-xs-attribute-group-name resolved))
+ (setf (soap-xs-attribute-group-id attribute-group)
+ (soap-xs-attribute-group-id resolved))
+ (setf (soap-xs-attribute-group-reference attribute-group) nil)
+ (setf (soap-xs-attribute-group-attributes attribute-group)
+ (soap-xs-attribute-group-attributes resolved))
+ (setf (soap-xs-attribute-group-attribute-groups attribute-group)
+ (soap-xs-attribute-group-attribute-groups resolved))))))
+
+(put (aref (make-soap-xs-attribute-group) 0)
+ 'soap-resolve-references #'soap-resolve-references-for-xs-attribute-group)
+
+;;;;; soap-xs-simple-type
+
+(defstruct (soap-xs-simple-type (:include soap-xs-type))
+ ;; A simple type is an extension on the basic type to which some
+ ;; restrictions can be added. For example we can define a simple type based
+ ;; off "string" with the restrictions that only the strings "one", "two" and
+ ;; "three" are valid values (this is an enumeration).
+
+ base ; can be a single type, or a list of types for union types
+ enumeration ; nil, or list of permitted values for the type
+ pattern ; nil, or value must match this pattern
+ length-range ; a cons of (min . max) length, inclusive range.
+ ; For exact length, use (l, l).
+ ; nil means no range,
+ ; (nil . l) means no min range,
+ ; (l . nil) means no max range.
+ integer-range ; a pair of (min, max) integer values, inclusive range,
+ ; same meaning as `length-range'
+ is-list ; t if this is an xs:list, nil otherwise
)
+(defun soap-xs-parse-simple-type (node)
+ "Construct an `soap-xs-simple-type' object from the XML NODE."
+ (assert (memq (soap-l2wk (xml-node-name node))
+ '(xsd:simpleType xsd:simpleContent))
+ nil
+ "expecting xsd:simpleType or xsd:simpleContent node, got %s"
+ (soap-l2wk (xml-node-name node)))
+
+ ;; NOTE: name can be nil for inline types. Such types cannot be added to a
+ ;; namespace.
+ (let ((name (xml-get-attribute-or-nil node 'name))
+ (id (xml-get-attribute-or-nil node 'id)))
+
+ (let ((type (make-soap-xs-simple-type
+ :name name :namespace-tag soap-target-xmlns :id id))
+ (def (soap-xml-node-find-matching-child
+ node '(xsd:restriction xsd:extension xsd:union xsd:list))))
+ (ecase (soap-l2wk (xml-node-name def))
+ (xsd:restriction (soap-xs-add-restriction def type))
+ (xsd:extension (soap-xs-add-extension def type))
+ (xsd:union (soap-xs-add-union def type))
+ (xsd:list (soap-xs-add-list def type)))
+
+ type)))
+
+(defun soap-xs-add-restriction (node type)
+ "Add restrictions defined in XML NODE to TYPE, an `soap-xs-simple-type'."
+
+ (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:restriction)
+ nil
+ "expecting xsd:restriction node, got %s"
+ (soap-l2wk (xml-node-name node)))
+
+ (setf (soap-xs-simple-type-base type)
+ (soap-l2fq (xml-get-attribute node 'base)))
+
+ (dolist (r (xml-node-children node))
+ (unless (stringp r) ; skip the white space
+ (let ((value (xml-get-attribute r 'value)))
+ (case (soap-l2wk (xml-node-name r))
+ (xsd:enumeration
+ (push value (soap-xs-simple-type-enumeration type)))
+ (xsd:pattern
+ (setf (soap-xs-simple-type-pattern type)
+ (concat "\\`" (xsdre-translate value) "\\'")))
+ (xsd:length
+ (let ((value (string-to-number value)))
+ (setf (soap-xs-simple-type-length-range type)
+ (cons value value))))
+ (xsd:minLength
+ (let ((value (string-to-number value)))
+ (setf (soap-xs-simple-type-length-range type)
+ (if (soap-xs-simple-type-length-range type)
+ (cons value
+ (cdr (soap-xs-simple-type-length-range type)))
+ ;; else
+ (cons value nil)))))
+ (xsd:maxLength
+ (let ((value (string-to-number value)))
+ (setf (soap-xs-simple-type-length-range type)
+ (if (soap-xs-simple-type-length-range type)
+ (cons (car (soap-xs-simple-type-length-range type))
+ value)
+ ;; else
+ (cons nil value)))))
+ (xsd:minExclusive
+ (let ((value (string-to-number value)))
+ (setf (soap-xs-simple-type-integer-range type)
+ (if (soap-xs-simple-type-integer-range type)
+ (cons (1+ value)
+ (cdr (soap-xs-simple-type-integer-range type)))
+ ;; else
+ (cons (1+ value) nil)))))
+ (xsd:maxExclusive
+ (let ((value (string-to-number value)))
+ (setf (soap-xs-simple-type-integer-range type)
+ (if (soap-xs-simple-type-integer-range type)
+ (cons (car (soap-xs-simple-type-integer-range type))
+ (1- value))
+ ;; else
+ (cons nil (1- value))))))
+ (xsd:minInclusive
+ (let ((value (string-to-number value)))
+ (setf (soap-xs-simple-type-integer-range type)
+ (if (soap-xs-simple-type-integer-range type)
+ (cons value
+ (cdr (soap-xs-simple-type-integer-range type)))
+ ;; else
+ (cons value nil)))))
+ (xsd:maxInclusive
+ (let ((value (string-to-number value)))
+ (setf (soap-xs-simple-type-integer-range type)
+ (if (soap-xs-simple-type-integer-range type)
+ (cons (car (soap-xs-simple-type-integer-range type))
+ value)
+ ;; else
+ (cons nil value))))))))))
+
+(defun soap-xs-add-union (node type)
+ "Add union members defined in XML NODE to TYPE, an `soap-xs-simple-type'."
+ (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:union)
+ nil
+ "expecting xsd:union node, got %s" (soap-l2wk (xml-node-name node)))
+
+ (setf (soap-xs-simple-type-base type)
+ (mapcar 'soap-l2fq
+ (split-string
+ (or (xml-get-attribute-or-nil node 'memberTypes) ""))))
+
+ ;; Additional simple types can be defined inside the union node. Add them
+ ;; to the base list. The "memberTypes" members will have to be resolved by
+ ;; the "resolve-references" method, the inline types will not.
+ (let (result)
+ (dolist (simple-type (soap-xml-get-children1 node 'xsd:simpleType))
+ (push (soap-xs-parse-simple-type simple-type) result))
+ (setf (soap-xs-simple-type-base type)
+ (append (soap-xs-simple-type-base type) (nreverse result)))))
+
+(defun soap-xs-add-list (node type)
+ "Add list defined in XML NODE to TYPE, a `soap-xs-simple-type'."
+ (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:list)
+ nil
+ "expecting xsd:list node, got %s" (soap-l2wk (xml-node-name node)))
+
+ ;; A simple type can be defined inline inside the list node or referenced by
+ ;; the itemType attribute, in which case it will be resolved by the
+ ;; resolve-references method.
+ (let* ((item-type (xml-get-attribute-or-nil node 'itemType))
+ (children (soap-xml-get-children1 node 'xsd:simpleType)))
+ (if item-type
+ (if (= (length children) 0)
+ (setf (soap-xs-simple-type-base type) (soap-l2fq item-type))
+ (soap-warning
+ "xsd:list node with itemType has more than zero children: %s"
+ (soap-xs-type-name type)))
+ (if (= (length children) 1)
+ (setf (soap-xs-simple-type-base type)
+ (soap-xs-parse-simple-type
+ (car (soap-xml-get-children1 node 'xsd:simpleType))))
+ (soap-warning "xsd:list node has more than one child %s"
+ (soap-xs-type-name type))))
+ (setf (soap-xs-simple-type-is-list type) t)))
+
+(defun soap-xs-add-extension (node type)
+ "Add the extended type defined in XML NODE to TYPE, an
`soap-xs-simple-type'."
+ (setf (soap-xs-simple-type-base type)
+ (soap-l2fq (xml-get-attribute node 'base)))
+ (dolist (attribute (soap-xml-get-children1 node 'xsd:attribute))
+ (push (soap-xs-parse-attribute attribute)
+ (soap-xs-type-attributes type)))
+ (dolist (attribute-group (soap-xml-get-children1 node 'xsd:attributeGroup))
+ (push (soap-xs-parse-attribute-group attribute-group)
+ (soap-xs-type-attribute-groups type))))
+
+(defun soap-validate-xs-basic-type (value type)
+ "Validate VALUE against the basic type TYPE."
+ (let* ((kind (soap-xs-basic-type-kind type)))
+ (case kind
+ ((anyType Array byte[])
+ value)
+ (t
+ (let ((convert (get kind 'rng-xsd-convert)))
+ (if convert
+ (if (rng-dt-make-value convert value)
+ value
+ (error "Invalid %s: %s" (symbol-name kind) value))
+ (error "Don't know how to convert %s" kind)))))))
+
+(defun soap-validate-xs-simple-type (value type)
+ "Validate VALUE against the restrictions of TYPE."
+
+ (let* ((base-type (soap-xs-simple-type-base type))
+ (messages nil))
+ (if (listp base-type)
+ (catch 'valid
+ (dolist (base base-type)
+ (condition-case error-object
+ (cond ((soap-xs-simple-type-p base)
+ (throw 'valid
+ (soap-validate-xs-simple-type value base)))
+ ((soap-xs-basic-type-p base)
+ (throw 'valid
+ (soap-validate-xs-basic-type value base))))
+ (error (push (cadr error-object) messages))))
+ (when messages
+ (error (mapconcat 'identity (nreverse messages) "; and: "))))
+ (cl-flet ((fail-with-message (format value)
+ (push (format format value) messages)
+ (throw 'invalid nil)))
+ (catch 'invalid
+ (let ((enumeration (soap-xs-simple-type-enumeration type)))
+ (when (and (> (length enumeration) 1)
+ (not (member value enumeration)))
+ (fail-with-message "bad value, should be one of %s"
enumeration)))
+
+ (let ((pattern (soap-xs-simple-type-pattern type)))
+ (when (and pattern (not (string-match-p pattern value)))
+ (fail-with-message "bad value, should match pattern %s"
pattern)))
+
+ (let ((length-range (soap-xs-simple-type-length-range type)))
+ (when length-range
+ (unless (stringp value)
+ (fail-with-message
+ "bad value, should be a string with length range %s"
+ length-range))
+ (when (car length-range)
+ (unless (>= (length value) (car length-range))
+ (fail-with-message "short string, should be at least %s
chars"
+ (car length-range))))
+ (when (cdr length-range)
+ (unless (<= (length value) (cdr length-range))
+ (fail-with-message "long string, should be at most %s chars"
+ (cdr length-range))))))
+
+ (let ((integer-range (soap-xs-simple-type-integer-range type)))
+ (when integer-range
+ (unless (numberp value)
+ (fail-with-message "bad value, should be a number with range
%s"
+ integer-range))
+ (when (car integer-range)
+ (unless (>= value (car integer-range))
+ (fail-with-message "small value, should be at least %s"
+ (car integer-range))))
+ (when (cdr integer-range)
+ (unless (<= value (cdr integer-range))
+ (fail-with-message "big value, should be at most %s"
+ (cdr integer-range))))))))
+ (when messages
+ (error "Xs-simple-type(%s, %s): %s"
+ value (or (soap-xs-type-name type) (soap-xs-type-id type))
+ (car messages)))))
+ ;; Return the validated value.
+ value)
+
+(defun soap-resolve-references-for-xs-simple-type (type wsdl)
+ "Replace names in TYPE with the referenced objects in the WSDL.
+This is a specialization of `soap-resolve-references' for
+`soap-xs-simple-type' objects.
+
+See also `soap-wsdl-resolve-references'."
+
+ (let ((namespace (soap-element-namespace-tag type)))
+ (when namespace
+ (let ((nstag (car (rassoc namespace (soap-wsdl-alias-table wsdl)))))
+ (when nstag
+ (setf (soap-element-namespace-tag type) nstag)))))
+
+ (let ((base (soap-xs-simple-type-base type)))
+ (cond
+ ((soap-name-p base)
+ (setf (soap-xs-simple-type-base type)
+ (soap-wsdl-get base wsdl 'soap-xs-type-p)))
+ ((soap-xs-type-p base)
+ (soap-resolve-references base wsdl))
+ ((listp base)
+ (setf (soap-xs-simple-type-base type)
+ (mapcar (lambda (type)
+ (cond ((soap-name-p type)
+ (soap-wsdl-get type wsdl 'soap-xs-type-p))
+ ((soap-xs-type-p type)
+ (soap-resolve-references type wsdl)
+ type)
+ (t ; signal an error?
+ type)))
+ base)))
+ (t (error "Oops"))))
+ (dolist (attribute (soap-xs-type-attributes type))
+ (soap-resolve-references attribute wsdl))
+ (dolist (attribute-group (soap-xs-type-attribute-groups type))
+ (soap-resolve-references attribute-group wsdl)))
+
+(defun soap-encode-xs-simple-type-attributes (value type)
+ "Encode the XML attributes for VALUE according to TYPE.
+The xsi:type and an optional xsi:nil attributes are added. The
+attributes are inserted in the current buffer at the current
+position.
+
+This is a specialization of `soap-encode-attributes' for
+`soap-xs-simple-type' objects."
+ (insert " xsi:type=\"" (soap-element-fq-name type) "\"")
+ (unless value (insert " xsi:nil=\"true\"")))
+
+(defun soap-encode-xs-simple-type (value type)
+ "Encode the VALUE according to TYPE.
+The data is inserted in the current buffer at the current
+position.
+
+This is a specialization of `soap-encode-value' for
+`soap-xs-simple-type' objects."
+ (soap-validate-xs-simple-type value type)
+ (if (soap-xs-simple-type-is-list type)
+ (progn
+ (dolist (v (butlast value))
+ (soap-encode-value v (soap-xs-simple-type-base type))
+ (insert " "))
+ (soap-encode-value (car (last value)) (soap-xs-simple-type-base type)))
+ (soap-encode-value value (soap-xs-simple-type-base type))))
+
+(defun soap-decode-xs-simple-type (type node)
+ "Use TYPE, a `soap-xs-simple-type', to decode the contents of NODE.
+A LISP value is returned based on the contents of NODE and the
+type-info stored in TYPE.
+
+This is a specialization of `soap-decode-type' for
+`soap-xs-simple-type' objects."
+ (if (soap-xs-simple-type-is-list type)
+ ;; Technically, we could construct fake XML NODEs and pass them to
+ ;; soap-decode-value...
+ (split-string (car (xml-node-children node)))
+ (let ((value (soap-decode-type (soap-xs-simple-type-base type) node)))
+ (soap-validate-xs-simple-type value type))))
+
+;; Register methods for `soap-xs-simple-type'
+(let ((tag (aref (make-soap-xs-simple-type) 0)))
+ (put tag 'soap-resolve-references
+ #'soap-resolve-references-for-xs-simple-type)
+ (put tag 'soap-attribute-encoder #'soap-encode-xs-simple-type-attributes)
+ (put tag 'soap-encoder #'soap-encode-xs-simple-type)
+ (put tag 'soap-decoder #'soap-decode-xs-simple-type))
+
+;;;;; soap-xs-complex-type
+
+(defstruct (soap-xs-complex-type (:include soap-xs-type))
+ indicator ; sequence, choice, all, array
+ base
+ elements
+ optional?
+ multiple?
+ is-group)
+
+(defun soap-xs-parse-complex-type (node)
+ "Construct a `soap-xs-complex-type' by parsing the XML NODE."
+ (let ((name (xml-get-attribute-or-nil node 'name))
+ (id (xml-get-attribute-or-nil node 'id))
+ (node-name (soap-l2wk (xml-node-name node)))
+ type
+ attributes
+ attribute-groups)
+ (assert (memq node-name '(xsd:complexType xsd:complexContent xsd:group))
+ nil "unexpected node: %s" node-name)
+
+ (dolist (def (xml-node-children node))
+ (when (consp def) ; skip text nodes
+ (case (soap-l2wk (xml-node-name def))
+ (xsd:attribute (push (soap-xs-parse-attribute def) attributes))
+ (xsd:attributeGroup
+ (push (soap-xs-parse-attribute-group def)
+ attribute-groups))
+ (xsd:simpleContent (setq type (soap-xs-parse-simple-type def)))
+ ((xsd:sequence xsd:all xsd:choice)
+ (setq type (soap-xs-parse-sequence def)))
+ (xsd:complexContent
+ (dolist (def (xml-node-children def))
+ (when (consp def)
+ (case (soap-l2wk (xml-node-name def))
+ (xsd:attribute
+ (push (soap-xs-parse-attribute def) attributes))
+ (xsd:attributeGroup
+ (push (soap-xs-parse-attribute-group def)
+ attribute-groups))
+ ((xsd:extension xsd:restriction)
+ (setq type
+ (soap-xs-parse-extension-or-restriction def)))
+ ((xsd:sequence xsd:all xsd:choice)
+ (soap-xs-parse-sequence def)))))))))
+ (unless type
+ ;; the type has not been built, this is a shortcut for a simpleContent
+ ;; node
+ (setq type (make-soap-xs-complex-type)))
+
+ (setf (soap-xs-type-name type) name)
+ (setf (soap-xs-type-namespace-tag type) soap-target-xmlns)
+ (setf (soap-xs-type-id type) id)
+ (setf (soap-xs-type-attributes type)
+ (append attributes (soap-xs-type-attributes type)))
+ (setf (soap-xs-type-attribute-groups type)
+ (append attribute-groups (soap-xs-type-attribute-groups type)))
+ (when (soap-xs-complex-type-p type)
+ (setf (soap-xs-complex-type-is-group type)
+ (eq node-name 'xsd:group)))
+ type))
+
+(defun soap-xs-parse-sequence (node)
+ "Parse a sequence definition from XML NODE.
+Returns a `soap-xs-complex-type'"
+ (assert (memq (soap-l2wk (xml-node-name node))
+ '(xsd:sequence xsd:choice xsd:all))
+ nil
+ "unexpected node: %s" (soap-l2wk (xml-node-name node)))
+
+ (let ((type (make-soap-xs-complex-type)))
+
+ (setf (soap-xs-complex-type-indicator type)
+ (ecase (soap-l2wk (xml-node-name node))
+ (xsd:sequence 'sequence)
+ (xsd:all 'all)
+ (xsd:choice 'choice)))
+
+ (setf (soap-xs-complex-type-optional? type) (soap-node-optional node))
+ (setf (soap-xs-complex-type-multiple? type) (soap-node-multiple node))
+
+ (dolist (r (xml-node-children node))
+ (unless (stringp r) ; skip the white space
+ (case (soap-l2wk (xml-node-name r))
+ ((xsd:element xsd:group)
+ (push (soap-xs-parse-element r)
+ (soap-xs-complex-type-elements type)))
+ ((xsd:sequence xsd:choice xsd:all)
+ ;; an inline sequence, choice or all node
+ (let ((choice (soap-xs-parse-sequence r)))
+ (push (make-soap-xs-element :name nil :type^ choice)
+ (soap-xs-complex-type-elements type))))
+ (xsd:attribute
+ (push (soap-xs-parse-attribute r)
+ (soap-xs-type-attributes type)))
+ (xsd:attributeGroup
+ (push (soap-xs-parse-attribute-group r)
+ (soap-xs-type-attribute-groups type))))))
+
+ (setf (soap-xs-complex-type-elements type)
+ (nreverse (soap-xs-complex-type-elements type)))
+
+ type))
+
+(defun soap-xs-parse-extension-or-restriction (node)
+ "Parse an extension or restriction definition from XML NODE.
+Return a `soap-xs-complex-type'."
+ (assert (memq (soap-l2wk (xml-node-name node))
+ '(xsd:extension xsd:restriction))
+ nil
+ "unexpected node: %s" (soap-l2wk (xml-node-name node)))
+ (let (type
+ attributes
+ attribute-groups
+ array?
+ (base (xml-get-attribute-or-nil node 'base)))
+
+ ;; Array declarations are recognized specially, it is unclear to me how
+ ;; they could be treated generally...
+ (setq array?
+ (and (eq (soap-l2wk (xml-node-name node)) 'xsd:restriction)
+ (equal base (soap-wk2l "soapenc:Array"))))
+
+ (dolist (def (xml-node-children node))
+ (when (consp def) ; skip text nodes
+ (case (soap-l2wk (xml-node-name def))
+ ((xsd:sequence xsd:choice xsd:all)
+ (setq type (soap-xs-parse-sequence def)))
+ (xsd:attribute
+ (if array?
+ (let ((array-type
+ (soap-xml-get-attribute-or-nil1 def 'wsdl:arrayType)))
+ (when (and array-type
+ (string-match "^\\(.*\\)\\[\\]$" array-type))
+ ;; Override
+ (setq base (match-string 1 array-type))))
+ ;; else
+ (push (soap-xs-parse-attribute def) attributes)))
+ (xsd:attributeGroup
+ (push (soap-xs-parse-attribute-group def) attribute-groups)))))
+
+ (unless type
+ (setq type (make-soap-xs-complex-type))
+ (when array?
+ (setf (soap-xs-complex-type-indicator type) 'array)))
+
+ (setf (soap-xs-complex-type-base type) (soap-l2fq base))
+ (setf (soap-xs-complex-type-attributes type) attributes)
+ (setf (soap-xs-complex-type-attribute-groups type) attribute-groups)
+ type))
+
+(defun soap-resolve-references-for-xs-complex-type (type wsdl)
+ "Replace names in TYPE with the referenced objects in the WSDL.
+This is a specialization of `soap-resolve-references' for
+`soap-xs-complex-type' objects.
+
+See also `soap-wsdl-resolve-references'."
+
+ (let ((namespace (soap-element-namespace-tag type)))
+ (when namespace
+ (let ((nstag (car (rassoc namespace (soap-wsdl-alias-table wsdl)))))
+ (when nstag
+ (setf (soap-element-namespace-tag type) nstag)))))
+
+ (let ((base (soap-xs-complex-type-base type)))
+ (cond ((soap-name-p base)
+ (setf (soap-xs-complex-type-base type)
+ (soap-wsdl-get base wsdl 'soap-xs-type-p)))
+ ((soap-xs-type-p base)
+ (soap-resolve-references base wsdl))))
+ (let (all-elements)
+ (dolist (element (soap-xs-complex-type-elements type))
+ (if (soap-xs-element-is-group element)
+ ;; This is an xsd:group element that references an xsd:group node,
+ ;; which we treat as a complex type. We replace the reference
+ ;; element by inlining the elements of the referenced xsd:group
+ ;; (complex type) node.
+ (let ((type (soap-wsdl-get
+ (soap-xs-element-reference element)
+ wsdl (lambda (type)
+ (and
+ (soap-xs-complex-type-p type)
+ (soap-xs-complex-type-is-group type))))))
+ (dolist (element (soap-xs-complex-type-elements type))
+ (soap-resolve-references element wsdl)
+ (push element all-elements)))
+ ;; This is a non-xsd:group node so just add it directly.
+ (soap-resolve-references element wsdl)
+ (push element all-elements)))
+ (setf (soap-xs-complex-type-elements type) (nreverse all-elements)))
+ (dolist (attribute (soap-xs-type-attributes type))
+ (soap-resolve-references attribute wsdl))
+ (dolist (attribute-group (soap-xs-type-attribute-groups type))
+ (soap-resolve-references attribute-group wsdl)))
+
+(defun soap-encode-xs-complex-type-attributes (value type)
+ "Encode the XML attributes for encoding VALUE according to TYPE.
+The xsi:type and optional xsi:nil attributes are added, plus
+additional attributes needed for arrays types, if applicable. The
+attributes are inserted in the current buffer at the current
+position.
+
+This is a specialization of `soap-encode-attributes' for
+`soap-xs-complex-type' objects."
+ (if (eq (soap-xs-complex-type-indicator type) 'array)
+ (let ((element-type (soap-xs-complex-type-base type)))
+ (insert " xsi:type=\"soapenc:Array\"")
+ (insert " soapenc:arrayType=\""
+ (soap-element-fq-name element-type)
+ "[" (format "%s" (length value)) "]" "\""))
+ ;; else
+ (progn
+ (dolist (a (soap-get-xs-attributes type))
+ (let ((element-name (soap-element-name a)))
+ (if (soap-xs-attribute-default a)
+ (insert " " element-name
+ "=\"" (soap-xs-attribute-default a) "\"")
+ (dolist (value-pair value)
+ (when (equal element-name (symbol-name (car value-pair)))
+ (insert " " element-name
+ "=\"" (cdr value-pair) "\""))))))
+ ;; If this is not an empty type, and we have no value, mark it as nil
+ (when (and (soap-xs-complex-type-indicator type) (null value))
+ (insert " xsi:nil=\"true\"")))))
+
+(defun soap-get-candidate-elements (element)
+ "Return a list of elements that are compatible with ELEMENT.
+The returned list includes ELEMENT's references and
+alternatives."
+ (let ((reference (soap-xs-element-reference element)))
+ ;; If the element is a reference, append the reference and its
+ ;; alternatives...
+ (if reference
+ (append (list reference)
+ (soap-xs-element-alternatives reference))
+ ;; ...otherwise append the element itself and its alternatives.
+ (append (list element)
+ (soap-xs-element-alternatives element)))))
+
+(defun soap-encode-xs-complex-type (value type)
+ "Encode the VALUE according to TYPE.
+The data is inserted in the current buffer at the current
+position.
+
+This is a specialization of `soap-encode-value' for
+`soap-xs-complex-type' objects."
+ (case (soap-xs-complex-type-indicator type)
+ (array
+ (error "soap-encode-xs-complex-type arrays are handled elsewhere"))
+ ((sequence choice all nil)
+ (let ((type-list (list type)))
+
+ ;; Collect all base types
+ (let ((base (soap-xs-complex-type-base type)))
+ (while base
+ (push base type-list)
+ (setq base (soap-xs-complex-type-base base))))
+
+ (dolist (type type-list)
+ (dolist (element (soap-xs-complex-type-elements type))
+ (catch 'done
+ (let ((instance-count 0))
+ (dolist (candidate (soap-get-candidate-elements element))
+ (let ((e-name (soap-xs-element-name candidate)))
+ (if e-name
+ (let ((e-name (intern e-name)))
+ (dolist (v value)
+ (when (equal (car v) e-name)
+ (incf instance-count)
+ (soap-encode-value (cdr v) candidate))))
+ (if (soap-xs-complex-type-indicator type)
+ (let ((current-point (point)))
+ ;; Check if encoding happened by checking if
+ ;; characters were inserted in the buffer.
+ (soap-encode-value value candidate)
+ (when (not (equal current-point (point)))
+ (incf instance-count)))
+ (dolist (v value)
+ (let ((current-point (point)))
+ (soap-encode-value v candidate)
+ (when (not (equal current-point (point)))
+ (incf instance-count))))))))
+ ;; Do some sanity checking
+ (let* ((indicator (soap-xs-complex-type-indicator type))
+ (element-type (soap-xs-element-type element))
+ (reference (soap-xs-element-reference element))
+ (e-name (or (soap-xs-element-name element)
+ (and reference
+ (soap-xs-element-name reference)))))
+ (cond ((and (eq indicator 'choice)
+ (> instance-count 0))
+ ;; This was a choice node and we encoded
+ ;; one instance.
+ (throw 'done t))
+ ((and (not (eq indicator 'choice))
+ (= instance-count 0)
+ (not (soap-xs-element-optional? element))
+ (and (soap-xs-complex-type-p element-type)
+ (not (soap-xs-complex-type-optional-p
+ element-type))))
+ (soap-warning
+ "While encoding %s: missing non-nillable slot %s"
+ value e-name))
+ ((and (> instance-count 1)
+ (not (soap-xs-element-multiple? element))
+ (and (soap-xs-complex-type-p element-type)
+ (not (soap-xs-complex-type-multiple-p
+ element-type))))
+ (soap-warning
+ (concat "While encoding %s: expected single,"
+ " found multiple elements for slot %s")
+ value e-name))))))))))
+ (t
+ (error "Don't know how to encode complex type: %s"
+ (soap-xs-complex-type-indicator type)))))
+
+(defun soap-xml-get-children-fq (node child-name)
+ "Return the children of NODE named CHILD-NAME.
+This is the same as `xml-get-children1', but NODE's local
+namespace is used to resolve the children's namespace tags."
+ (let (result)
+ (dolist (c (xml-node-children node))
+ (when (and (consp c)
+ (soap-with-local-xmlns node
+ ;; We use `ignore-errors' here because we want to silently
+ ;; skip nodes for which we cannot convert them to a
+ ;; well-known name.
+ (equal (ignore-errors
+ (soap-l2fq (xml-node-name c)))
+ child-name)))
+ (push c result)))
+ (nreverse result)))
+
+(defun soap-xs-element-get-fq-name (element wsdl)
+ "Return ELEMENT's fully-qualified name using WSDL's alias table.
+Return nil if ELEMENT does not have a name."
+ (let* ((ns-aliases (soap-wsdl-alias-table wsdl))
+ (ns-name (cdr (assoc
+ (soap-element-namespace-tag element)
+ ns-aliases))))
+ (when ns-name
+ (cons ns-name (soap-element-name element)))))
+
+(defun soap-xs-complex-type-optional-p (type)
+ "Return t if TYPE or any of TYPE's ancestor types is optional.
+Return nil otherwise."
+ (when type
+ (or (soap-xs-complex-type-optional? type)
+ (and (soap-xs-complex-type-p type)
+ (soap-xs-complex-type-optional-p
+ (soap-xs-complex-type-base type))))))
+
+(defun soap-xs-complex-type-multiple-p (type)
+ "Return t if TYPE or any of TYPE's ancestor types permits multiple elements.
+Return nil otherwise."
+ (when type
+ (or (soap-xs-complex-type-multiple? type)
+ (and (soap-xs-complex-type-p type)
+ (soap-xs-complex-type-multiple-p
+ (soap-xs-complex-type-base type))))))
+
+(defun soap-get-xs-attributes-from-groups (attribute-groups)
+ "Return a list of attributes from all ATTRIBUTE-GROUPS."
+ (let (attributes)
+ (dolist (group attribute-groups)
+ (let ((sub-groups (soap-xs-attribute-group-attribute-groups group)))
+ (setq attributes (append attributes
+ (soap-get-xs-attributes-from-groups
sub-groups)
+ (soap-xs-attribute-group-attributes group)))))
+ attributes))
+
+(defun soap-get-xs-attributes (type)
+ "Return a list of all of TYPE's and TYPE's ancestors' attributes."
+ (let* ((base (and (soap-xs-complex-type-p type)
+ (soap-xs-complex-type-base type)))
+ (attributes (append (soap-xs-type-attributes type)
+ (soap-get-xs-attributes-from-groups
+ (soap-xs-type-attribute-groups type)))))
+ (if base
+ (append attributes (soap-get-xs-attributes base))
+ attributes)))
+
+(defun soap-decode-xs-attributes (type node)
+ "Use TYPE, a `soap-xs-complex-type', to decode the attributes of NODE."
+ (let (result)
+ (dolist (attribute (soap-get-xs-attributes type))
+ (let* ((name (soap-xs-attribute-name attribute))
+ (attribute-type (soap-xs-attribute-type attribute))
+ (symbol (intern name))
+ (value (xml-get-attribute-or-nil node symbol)))
+ ;; We don't support attribute uses: required, optional, prohibited.
+ (cond
+ ((soap-xs-basic-type-p attribute-type)
+ ;; Basic type values are validated by xml.el.
+ (when value
+ (push (cons symbol
+ ;; Create a fake XML node to satisfy the
+ ;; soap-decode-xs-basic-type API.
+ (soap-decode-xs-basic-type attribute-type
+ (list symbol nil value)))
+ result)))
+ ((soap-xs-simple-type-p attribute-type)
+ (when value
+ (push (cons symbol
+ (soap-validate-xs-simple-type value attribute-type))
+ result)))
+ (t
+ (error (concat "Attribute %s is of type %s which is"
+ " not a basic or simple type")
+ name (soap-name-p attribute))))))
+ result))
+
+(defun soap-decode-xs-complex-type (type node)
+ "Use TYPE, a `soap-xs-complex-type', to decode the contents of NODE.
+A LISP value is returned based on the contents of NODE and the
+type-info stored in TYPE.
+
+This is a specialization of `soap-decode-type' for
+`soap-xs-basic-type' objects."
+ (case (soap-xs-complex-type-indicator type)
+ (array
+ (let ((result nil)
+ (element-type (soap-xs-complex-type-base type)))
+ (dolist (node (xml-node-children node))
+ (when (consp node)
+ (push (soap-decode-type element-type node) result)))
+ (nreverse result)))
+ ((sequence choice all nil)
+ (let ((result nil)
+ (base (soap-xs-complex-type-base type)))
+ (when base
+ (setq result (nreverse (soap-decode-type base node))))
+ (catch 'done
+ (dolist (element (soap-xs-complex-type-elements type))
+ (let* ((instance-count 0)
+ (e-name (soap-xs-element-name element))
+ ;; Heuristic: guess if we need to decode using local
+ ;; namespaces.
+ (use-fq-names (string-match ":" (symbol-name (car node))))
+ (children (if e-name
+ (if use-fq-names
+ ;; Find relevant children
+ ;; using local namespaces by
+ ;; searching for the element's
+ ;; fully-qualified name.
+ (soap-xml-get-children-fq
+ node
+ (soap-xs-element-get-fq-name
+ element soap-current-wsdl))
+ ;; No local namespace resolution
+ ;; needed so use the element's
+ ;; name unqualified.
+ (xml-get-children node (intern e-name)))
+ ;; e-name is nil so a) we don't know which
+ ;; children to operate on, and b) we want to
+ ;; re-use soap-decode-xs-complex-type, which
+ ;; expects a node argument with a complex
+ ;; type; therefore we need to operate on the
+ ;; entire node. We wrap node in a list so
+ ;; that it will carry through as "node" in the
+ ;; loop below.
+ ;;
+ ;; For example:
+ ;;
+ ;; Element Type:
+ ;; <xs:complexType name="A">
+ ;; <xs:sequence>
+ ;; <xs:element name="B" type="t:BType"/>
+ ;; <xs:choice>
+ ;; <xs:element name="C" type="xs:string"/>
+ ;; <xs:element name="D" type="t:DType"/>
+ ;; </xs:choice>
+ ;; </xs:sequence>
+ ;; </xs:complexType>
+ ;;
+ ;; Node:
+ ;; <t:A>
+ ;; <t:B tag="b"/>
+ ;; <t:C>1</C>
+ ;; </t:A>
+ ;;
+ ;; soap-decode-type will be called below with:
+ ;;
+ ;; element =
+ ;; <xs:choice>
+ ;; <xs:element name="C" type="xs:string"/>
+ ;; <xs:element name="D" type="t:DType"/>
+ ;; </xs:choice>
+ ;; node =
+ ;; <t:A>
+ ;; <t:B tag="b"/>
+ ;; <t:C>1</C>
+ ;; </t:A>
+ (list node)))
+ (element-type (soap-xs-element-type element)))
+ (dolist (node children)
+ (incf instance-count)
+ (let* ((attributes
+ (soap-decode-xs-attributes element-type node))
+ ;; Attributes may specify xsi:type override.
+ (element-type
+ (if (soap-xml-get-attribute-or-nil1 node 'xsi:type)
+ (soap-wsdl-get
+ (soap-l2fq
+ (soap-xml-get-attribute-or-nil1 node
+ 'xsi:type))
+ soap-current-wsdl 'soap-xs-type-p t)
+ element-type))
+ (decoded-child (soap-decode-type element-type node)))
+ (if e-name
+ (push (cons (intern e-name)
+ (append attributes decoded-child)) result)
+ ;; When e-name is nil we don't want to introduce an extra
+ ;; level of nesting, so we splice the decoding into
+ ;; result.
+ (setq result (append decoded-child result)))))
+ (cond ((and (eq (soap-xs-complex-type-indicator type) 'choice)
+ ;; Choices can allow multiple values.
+ (not (soap-xs-complex-type-multiple-p type))
+ (> instance-count 0))
+ ;; This was a choice node, and we decoded one value.
+ (throw 'done t))
+
+ ;; Do some sanity checking
+ ((and (not (eq (soap-xs-complex-type-indicator type)
+ 'choice))
+ (= instance-count 0)
+ (not (soap-xs-element-optional? element))
+ (and (soap-xs-complex-type-p element-type)
+ (not (soap-xs-complex-type-optional-p
+ element-type))))
+ (soap-warning "missing non-nillable slot %s" e-name))
+ ((and (> instance-count 1)
+ (not (soap-xs-complex-type-multiple-p type))
+ (not (soap-xs-element-multiple? element))
+ (and (soap-xs-complex-type-p element-type)
+ (not (soap-xs-complex-type-multiple-p
+ element-type))))
+ (soap-warning "expected single %s slot, found multiple"
+ e-name))))))
+ (nreverse result)))
+ (t
+ (error "Don't know how to decode complex type: %s"
+ (soap-xs-complex-type-indicator type)))))
+
+;; Register methods for `soap-xs-complex-type'
+(let ((tag (aref (make-soap-xs-complex-type) 0)))
+ (put tag 'soap-resolve-references
+ #'soap-resolve-references-for-xs-complex-type)
+ (put tag 'soap-attribute-encoder #'soap-encode-xs-complex-type-attributes)
+ (put tag 'soap-encoder #'soap-encode-xs-complex-type)
+ (put tag 'soap-decoder #'soap-decode-xs-complex-type))
+
+;;;; WSDL documents
+;;;;; WSDL document elements
+
+
(defstruct (soap-message (:include soap-element))
parts ; ALIST of NAME => WSDL-TYPE name
)
@@ -393,7 +1945,9 @@ binding) but the same name."
parameter-order
input ; (NAME . MESSAGE)
output ; (NAME . MESSAGE)
- faults) ; a list of (NAME . MESSAGE)
+ faults ; a list of (NAME . MESSAGE)
+ input-action ; WS-addressing action string
+ output-action) ; WS-addressing action string
(defstruct (soap-port-type (:include soap-element))
operations) ; a namespace of operations
@@ -404,8 +1958,10 @@ binding) but the same name."
(defstruct soap-bound-operation
operation ; SOAP-OPERATION
soap-action ; value for SOAPAction HTTP header
+ soap-headers ; list of (message part use)
+ soap-body ; message parts present in the body
use ; 'literal or 'encoded, see
- ; http://www.w3.org/TR/wsdl#_soap:body
+ ; http://www.w3.org/TR/wsdl#_soap:body
)
(defstruct (soap-binding (:include soap-element))
@@ -416,49 +1972,49 @@ binding) but the same name."
service-url
binding)
-(defun soap-default-xsd-types ()
- "Return a namespace containing some of the XMLSchema types."
- (let ((ns (make-soap-namespace :name "http://www.w3.org/2001/XMLSchema";)))
- (dolist (type '("string" "dateTime" "boolean"
- "long" "int" "integer" "unsignedInt" "byte" "float"
"double"
- "base64Binary" "anyType" "anyURI" "Array" "byte[]"))
- (soap-namespace-put
- (make-soap-basic-type :name type :kind (intern type))
- ns))
- ns))
-
-(defun soap-default-soapenc-types ()
- "Return a namespace containing some of the SOAPEnc types."
- (let ((ns (make-soap-namespace
- :name "http://schemas.xmlsoap.org/soap/encoding/";)))
- (dolist (type '("string" "dateTime" "boolean"
- "long" "int" "integer" "unsignedInt" "byte" "float"
"double"
- "base64Binary" "anyType" "anyURI" "Array" "byte[]"))
- (soap-namespace-put
- (make-soap-basic-type :name type :kind (intern type))
- ns))
- ns))
-
-(defun soap-type-p (element)
- "Return t if ELEMENT is a SOAP data type (basic or complex)."
- (or (soap-basic-type-p element)
- (soap-sequence-type-p element)
- (soap-array-type-p element)))
-
;;;;; The WSDL document
;; The WSDL data structure used for encoding/decoding SOAP messages
-(defstruct soap-wsdl
+(defstruct (soap-wsdl
+ ;; NOTE: don't call this constructor, see `soap-make-wsdl'
+ (:constructor soap-make-wsdl^)
+ (:copier soap-copy-wsdl))
origin ; file or URL from which this wsdl was loaded
+ current-file ; most-recently fetched file or URL
+ xmlschema-imports ; a list of schema imports
ports ; a list of SOAP-PORT instances
alias-table ; a list of namespace aliases
namespaces ; a list of namespaces
)
+(defun soap-make-wsdl (origin)
+ "Create a new WSDL document, loaded from ORIGIN, and intialize it."
+ (let ((wsdl (soap-make-wsdl^ :origin origin)))
+
+ ;; Add the XSD types to the wsdl document
+ (let ((ns (soap-make-xs-basic-types
+ "http://www.w3.org/2001/XMLSchema"; "xsd")))
+ (soap-wsdl-add-namespace ns wsdl)
+ (soap-wsdl-add-alias "xsd" (soap-namespace-name ns) wsdl))
+
+ ;; Add the soapenc types to the wsdl document
+ (let ((ns (soap-make-xs-basic-types
+ "http://schemas.xmlsoap.org/soap/encoding/"; "soapenc")))
+ (soap-wsdl-add-namespace ns wsdl)
+ (soap-wsdl-add-alias "soapenc" (soap-namespace-name ns) wsdl))
+
+ wsdl))
+
(defun soap-wsdl-add-alias (alias name wsdl)
"Add a namespace ALIAS for NAME to the WSDL document."
- (push (cons alias name) (soap-wsdl-alias-table wsdl)))
+ (let ((existing (assoc alias (soap-wsdl-alias-table wsdl))))
+ (if existing
+ (unless (equal (cdr existing) name)
+ (warn "Redefining alias %s from %s to %s"
+ alias (cdr existing) name)
+ (push (cons alias name) (soap-wsdl-alias-table wsdl)))
+ (push (cons alias name) (soap-wsdl-alias-table wsdl)))))
(defun soap-wsdl-find-namespace (name wsdl)
"Find a namespace by NAME in the WSDL document."
@@ -474,11 +2030,11 @@ elements will be added to it."
(let ((existing (soap-wsdl-find-namespace (soap-namespace-name ns) wsdl)))
(if existing
;; Add elements from NS to EXISTING, replacing existing values.
- (maphash (lambda (key value)
+ (maphash (lambda (_key value)
(dolist (v value)
(soap-namespace-put v existing)))
(soap-namespace-elements ns))
- (push ns (soap-wsdl-namespaces wsdl)))))
+ (push ns (soap-wsdl-namespaces wsdl)))))
(defun soap-wsdl-get (name wsdl &optional predicate use-local-alias-table)
"Retrieve element NAME from the WSDL document.
@@ -517,13 +2073,13 @@ used to resolve the namespace alias."
(ns-name (cdr (assoc ns-alias alias-table))))
(unless ns-name
(error "Soap-wsdl-get(%s): cannot find namespace alias %s"
- name ns-alias))
+ name ns-alias))
(setq namespace (soap-wsdl-find-namespace ns-name wsdl))
(unless namespace
(error
- "Soap-wsdl-get(%s): unknown namespace %s, referenced by alias
%s"
- name ns-name ns-alias))))
+ "Soap-wsdl-get(%s): unknown namespace %s, referenced as %s"
+ name ns-name ns-alias))))
(t
(error "Soap-wsdl-get(%s): bad name" name)))
@@ -533,7 +2089,7 @@ used to resolve the namespace alias."
(lambda (e)
(or (funcall 'soap-namespace-link-p e)
(funcall predicate e)))
- nil)))
+ nil)))
(unless element
(error "Soap-wsdl-get(%s): cannot find element" name))
@@ -541,92 +2097,96 @@ used to resolve the namespace alias."
(if (soap-namespace-link-p element)
;; NOTE: don't use the local alias table here
(soap-wsdl-get (soap-namespace-link-target element) wsdl predicate)
- element)))
+ element)))
+
+;;;;; soap-parse-schema
+
+(defun soap-parse-schema (node wsdl)
+ "Parse a schema NODE, placing the results in WSDL.
+Return a SOAP-NAMESPACE containing the elements."
+ (soap-with-local-xmlns node
+ (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:schema)
+ nil
+ "expecting an xsd:schema node, got %s"
+ (soap-l2wk (xml-node-name node)))
+
+ (let ((ns (make-soap-namespace :name (soap-get-target-namespace node))))
+
+ (dolist (def (xml-node-children node))
+ (unless (stringp def) ; skip text nodes
+ (case (soap-l2wk (xml-node-name def))
+ (xsd:import
+ ;; Imports will be processed later
+ ;; NOTE: we should expand the location now!
+ (let ((location (or
+ (xml-get-attribute-or-nil def 'schemaLocation)
+ (xml-get-attribute-or-nil def 'location))))
+ (when location
+ (push location (soap-wsdl-xmlschema-imports wsdl)))))
+ (xsd:element
+ (soap-namespace-put (soap-xs-parse-element def) ns))
+ (xsd:attribute
+ (soap-namespace-put (soap-xs-parse-attribute def) ns))
+ (xsd:attributeGroup
+ (soap-namespace-put (soap-xs-parse-attribute-group def) ns))
+ (xsd:simpleType
+ (soap-namespace-put (soap-xs-parse-simple-type def) ns))
+ ((xsd:complexType xsd:group)
+ (soap-namespace-put (soap-xs-parse-complex-type def) ns)))))
+ ns)))
;;;;; Resolving references for wsdl types
;; See `soap-wsdl-resolve-references', which is the main entry point for
;; resolving references
-(defun soap-resolve-references-for-element (element wsdl)
- "Resolve references in ELEMENT using the WSDL document.
-This is a generic function which invokes a specific function
-depending on the element type.
+(defun soap-resolve-references (element wsdl)
+ "Replace names in ELEMENT with the referenced objects in the WSDL.
+This is a generic function which invokes a specific resolver
+function depending on the type of the ELEMENT.
-If ELEMENT has no resolver function, it is silently ignored.
-
-All references are resolved in-place, that is the ELEMENT is
-updated."
+If ELEMENT has no resolver function, it is silently ignored."
(let ((resolver (get (aref element 0) 'soap-resolve-references)))
(when resolver
(funcall resolver element wsdl))))
-(defun soap-resolve-references-for-simple-type (type wsdl)
- "Resolve the base type for the simple TYPE using the WSDL
- document."
- (let ((kind (soap-basic-type-kind type)))
- (unless (symbolp kind)
- (let ((basic-type (soap-wsdl-get kind wsdl 'soap-basic-type-p)))
- (setf (soap-basic-type-kind type)
- (soap-basic-type-kind basic-type))))))
-
-(defun soap-resolve-references-for-sequence-type (type wsdl)
- "Resolve references for a sequence TYPE using WSDL document.
-See also `soap-resolve-references-for-element' and
-`soap-wsdl-resolve-references'"
- (let ((parent (soap-sequence-type-parent type)))
- (when (or (consp parent) (stringp parent))
- (setf (soap-sequence-type-parent type)
- (soap-wsdl-get
- parent wsdl
- ;; Prevent self references, see Bug#9
- (lambda (e) (and (not (eq e type)) (soap-type-p e)))))))
- (dolist (element (soap-sequence-type-elements type))
- (let ((element-type (soap-sequence-element-type element)))
- (cond ((or (consp element-type) (stringp element-type))
- (setf (soap-sequence-element-type element)
- (soap-wsdl-get
- element-type wsdl
- ;; Prevent self references, see Bug#9
- (lambda (e) (and (not (eq e type)) (soap-type-p e))))))
- ((soap-element-p element-type)
- ;; since the element already has a child element, it
- ;; could be an inline structure. we must resolve
- ;; references in it, because it might not be reached by
- ;; scanning the wsdl names.
- (soap-resolve-references-for-element element-type wsdl))))))
-
-(defun soap-resolve-references-for-array-type (type wsdl)
- "Resolve references for an array TYPE using WSDL.
-See also `soap-resolve-references-for-element' and
-`soap-wsdl-resolve-references'"
- (let ((element-type (soap-array-type-element-type type)))
- (when (or (consp element-type) (stringp element-type))
- (setf (soap-array-type-element-type type)
- (soap-wsdl-get
- element-type wsdl
- ;; Prevent self references, see Bug#9
- (lambda (e) (and (not (eq e type)) (soap-type-p e))))))))
-
(defun soap-resolve-references-for-message (message wsdl)
- "Resolve references for a MESSAGE type using the WSDL document.
-See also `soap-resolve-references-for-element' and
-`soap-wsdl-resolve-references'"
+ "Replace names in MESSAGE with the referenced objects in the WSDL.
+This is a generic function, called by `soap-resolve-references',
+you should use that function instead.
+
+See also `soap-wsdl-resolve-references'."
(let (resolved-parts)
(dolist (part (soap-message-parts message))
(let ((name (car part))
- (type (cdr part)))
+ (element (cdr part)))
(when (stringp name)
(setq name (intern name)))
- (when (or (consp type) (stringp type))
- (setq type (soap-wsdl-get type wsdl 'soap-type-p)))
- (push (cons name type) resolved-parts)))
- (setf (soap-message-parts message) (nreverse resolved-parts))))
+ (if (soap-name-p element)
+ (setq element (soap-wsdl-get
+ element wsdl
+ (lambda (x)
+ (or (soap-xs-type-p x) (soap-xs-element-p x)))))
+ ;; else, inline element, resolve recursively, as the element
+ ;; won't be reached.
+ (soap-resolve-references element wsdl)
+ (unless (soap-element-namespace-tag element)
+ (setf (soap-element-namespace-tag element)
+ (soap-element-namespace-tag message))))
+ (push (cons name element) resolved-parts)))
+ (setf (soap-message-parts message) (nreverse resolved-parts))))
(defun soap-resolve-references-for-operation (operation wsdl)
"Resolve references for an OPERATION type using the WSDL document.
-See also `soap-resolve-references-for-element' and
+See also `soap-resolve-references' and
`soap-wsdl-resolve-references'"
+
+ (let ((namespace (soap-element-namespace-tag operation)))
+ (when namespace
+ (let ((nstag (car (rassoc namespace (soap-wsdl-alias-table wsdl)))))
+ (when nstag
+ (setf (soap-element-namespace-tag operation) nstag)))))
+
(let ((input (soap-operation-input operation))
(counter 0))
(let ((name (car input))
@@ -634,10 +2194,10 @@ See also `soap-resolve-references-for-element' and
;; Name this part if it was not named
(when (or (null name) (equal name ""))
(setq name (format "in%d" (incf counter))))
- (when (or (consp message) (stringp message))
+ (when (soap-name-p message)
(setf (soap-operation-input operation)
(cons (intern name)
- (soap-wsdl-get message wsdl 'soap-message-p))))))
+ (soap-wsdl-get message wsdl 'soap-message-p))))))
(let ((output (soap-operation-output operation))
(counter 0))
@@ -645,10 +2205,10 @@ See also `soap-resolve-references-for-element' and
(message (cdr output)))
(when (or (null name) (equal name ""))
(setq name (format "out%d" (incf counter))))
- (when (or (consp message) (stringp message))
+ (when (soap-name-p message)
(setf (soap-operation-output operation)
(cons (intern name)
- (soap-wsdl-get message wsdl 'soap-message-p))))))
+ (soap-wsdl-get message wsdl 'soap-message-p))))))
(let ((resolved-faults nil)
(counter 0))
@@ -657,11 +2217,11 @@ See also `soap-resolve-references-for-element' and
(message (cdr fault)))
(when (or (null name) (equal name ""))
(setq name (format "fault%d" (incf counter))))
- (if (or (consp message) (stringp message))
+ (if (soap-name-p message)
(push (cons (intern name)
- (soap-wsdl-get message wsdl 'soap-message-p))
+ (soap-wsdl-get message wsdl 'soap-message-p))
resolved-faults)
- (push fault resolved-faults))))
+ (push fault resolved-faults))))
(setf (soap-operation-faults operation) resolved-faults))
(when (= (length (soap-operation-parameter-order operation)) 0)
@@ -673,42 +2233,44 @@ See also `soap-resolve-references-for-element' and
(mapcar (lambda (p)
(if (stringp p)
(intern p)
- p))
+ p))
(soap-operation-parameter-order operation))))
(defun soap-resolve-references-for-binding (binding wsdl)
- "Resolve references for a BINDING type using the WSDL document.
-See also `soap-resolve-references-for-element' and
+ "Resolve references for a BINDING type using the WSDL document.
+See also `soap-resolve-references' and
`soap-wsdl-resolve-references'"
- (when (or (consp (soap-binding-port-type binding))
- (stringp (soap-binding-port-type binding)))
+ (when (soap-name-p (soap-binding-port-type binding))
(setf (soap-binding-port-type binding)
(soap-wsdl-get (soap-binding-port-type binding)
- wsdl 'soap-port-type-p)))
+ wsdl 'soap-port-type-p)))
(let ((port-ops (soap-port-type-operations (soap-binding-port-type
binding))))
(maphash (lambda (k v)
(setf (soap-bound-operation-operation v)
- (soap-namespace-get k port-ops 'soap-operation-p)))
+ (soap-namespace-get k port-ops 'soap-operation-p))
+ (let (resolved-headers)
+ (dolist (h (soap-bound-operation-soap-headers v))
+ (push (list (soap-wsdl-get (nth 0 h) wsdl)
+ (intern (nth 1 h))
+ (nth 2 h))
+ resolved-headers))
+ (setf (soap-bound-operation-soap-headers v)
+ (nreverse resolved-headers))))
(soap-binding-operations binding))))
(defun soap-resolve-references-for-port (port wsdl)
- "Resolve references for a PORT type using the WSDL document.
-See also `soap-resolve-references-for-element' and
-`soap-wsdl-resolve-references'"
- (when (or (consp (soap-port-binding port))
- (stringp (soap-port-binding port)))
+ "Replace names in PORT with the referenced objects in the WSDL.
+This is a generic function, called by `soap-resolve-references',
+you should use that function instead.
+
+See also `soap-wsdl-resolve-references'."
+ (when (soap-name-p (soap-port-binding port))
(setf (soap-port-binding port)
(soap-wsdl-get (soap-port-binding port) wsdl 'soap-binding-p))))
;; Install resolvers for our types
(progn
- (put (aref (make-soap-simple-type) 0) 'soap-resolve-references
- 'soap-resolve-references-for-simple-type)
- (put (aref (make-soap-sequence-type) 0) 'soap-resolve-references
- 'soap-resolve-references-for-sequence-type)
- (put (aref (make-soap-array-type) 0) 'soap-resolve-references
- 'soap-resolve-references-for-array-type)
(put (aref (make-soap-message) 0) 'soap-resolve-references
'soap-resolve-references-for-message)
(put (aref (make-soap-operation) 0) 'soap-resolve-references
@@ -745,312 +2307,173 @@ traverse an element tree."
(soap-wsdl-add-alias nstag (soap-namespace-name ns) wsdl)
(throw 'done t)))))
- (maphash (lambda (name element)
+ (maphash (lambda (_name element)
(cond ((soap-element-p element) ; skip links
(incf nprocessed)
- (soap-resolve-references-for-element element wsdl)
- (setf (soap-element-namespace-tag element) nstag))
+ (soap-resolve-references element wsdl))
((listp element)
(dolist (e element)
(when (soap-element-p e)
(incf nprocessed)
- (soap-resolve-references-for-element e wsdl)
- (setf (soap-element-namespace-tag e) nstag))))))
+ (soap-resolve-references e wsdl))))))
(soap-namespace-elements ns)))))
- wsdl)
+ wsdl)
;;;;; Loading WSDL from XML documents
-(defun soap-load-wsdl-from-url (url)
- "Load a WSDL document from URL and return it.
-The returned WSDL document needs to be used for `soap-invoke'
-calls."
- (let ((url-request-method "GET")
+(defun soap-parse-server-response ()
+ "Error-check and parse the XML contents of the current buffer."
+ (let ((mime-part (mm-dissect-buffer t t)))
+ (unless mime-part
+ (error "Failed to decode response from server"))
+ (unless (equal (car (mm-handle-type mime-part)) "text/xml")
+ (error "Server response is not an XML document"))
+ (with-temp-buffer
+ (mm-insert-part mime-part)
+ (prog1
+ (car (xml-parse-region (point-min) (point-max)))
+ (kill-buffer)
+ (mm-destroy-part mime-part)))))
+
+(defun soap-fetch-xml-from-url (url wsdl)
+ "Load an XML document from URL and return it.
+The previously parsed URL is read from WSDL."
+ (message "Fetching from %s" url)
+ (let ((current-file (url-expand-file-name url (soap-wsdl-current-file wsdl)))
+ (url-request-method "GET")
(url-package-name "soap-client.el")
(url-package-version "1.0")
(url-mime-charset-string "utf-8;q=1, iso-8859-1;q=0.5")
- (url-request-coding-system 'utf-8)
- (url-http-attempt-keepalives nil))
- (let ((buffer (url-retrieve-synchronously url)))
+ (url-http-attempt-keepalives t))
+ (setf (soap-wsdl-current-file wsdl) current-file)
+ (let ((buffer (url-retrieve-synchronously current-file)))
(with-current-buffer buffer
(declare (special url-http-response-status))
(if (> url-http-response-status 299)
(error "Error retrieving WSDL: %s" url-http-response-status))
- (let ((mime-part (mm-dissect-buffer t t)))
- (unless mime-part
- (error "Failed to decode response from server"))
- (unless (equal (car (mm-handle-type mime-part)) "text/xml")
- (error "Server response is not an XML document"))
- (with-temp-buffer
- (mm-insert-part mime-part)
- (let ((wsdl-xml (car (xml-parse-region (point-min) (point-max)))))
- (prog1
- (let ((wsdl (soap-parse-wsdl wsdl-xml)))
- (setf (soap-wsdl-origin wsdl) url)
- wsdl)
- (kill-buffer buffer)))))))))
-
-(defun soap-load-wsdl (file)
- "Load a WSDL document from FILE and return it."
- (with-temp-buffer
- (insert-file-contents file)
- (let ((xml (car (xml-parse-region (point-min) (point-max)))))
- (let ((wsdl (soap-parse-wsdl xml)))
- (setf (soap-wsdl-origin wsdl) file)
- wsdl))))
-
-(defun soap-parse-wsdl (node)
- "Construct a WSDL structure from NODE, which is an XML document."
+ (soap-parse-server-response)))))
+
+(defun soap-fetch-xml-from-file (file wsdl)
+ "Load an XML document from FILE and return it.
+The previously parsed file is read from WSDL."
+ (let* ((current-file (soap-wsdl-current-file wsdl))
+ (expanded-file (expand-file-name file
+ (if current-file
+ (file-name-directory
current-file)
+ default-directory))))
+ (setf (soap-wsdl-current-file wsdl) expanded-file)
+ (with-temp-buffer
+ (insert-file-contents expanded-file)
+ (car (xml-parse-region (point-min) (point-max))))))
+
+(defun soap-fetch-xml (file-or-url wsdl)
+ "Load an XML document from FILE-OR-URL and return it.
+The previously parsed file or URL is read from WSDL."
+ (let ((current-file (or (soap-wsdl-current-file wsdl) file-or-url)))
+ (if (or (and current-file (file-exists-p current-file))
+ (file-exists-p file-or-url))
+ (soap-fetch-xml-from-file file-or-url wsdl)
+ (soap-fetch-xml-from-url file-or-url wsdl))))
+
+(defun soap-load-wsdl (file-or-url &optional wsdl)
+ "Load a document from FILE-OR-URL and return it.
+Build on WSDL if it is provided."
+ (let* ((wsdl (or wsdl (soap-make-wsdl file-or-url)))
+ (xml (soap-fetch-xml file-or-url wsdl)))
+ (soap-wsdl-resolve-references (soap-parse-wsdl xml wsdl))
+ wsdl))
+
+(defalias 'soap-load-wsdl-from-url 'soap-load-wsdl)
+
+(defun soap-parse-wsdl-phase-validate-node (node)
+ "Assert that NODE is valid."
(soap-with-local-xmlns node
+ (let ((node-name (soap-l2wk (xml-node-name node))))
+ (assert (eq node-name 'wsdl:definitions)
+ nil
+ "expecting wsdl:definitions node, got %s" node-name))))
- (assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:definitions)
- nil
- "soap-parse-wsdl: expecting wsdl:definitions node, got %s"
- (soap-l2wk (xml-node-name node)))
-
- (let ((wsdl (make-soap-wsdl)))
-
- ;; Add the local alias table to the wsdl document -- it will be used for
- ;; all types in this document even after we finish parsing it.
- (setf (soap-wsdl-alias-table wsdl) soap-local-xmlns)
-
- ;; Add the XSD types to the wsdl document
- (let ((ns (soap-default-xsd-types)))
- (soap-wsdl-add-namespace ns wsdl)
- (soap-wsdl-add-alias "xsd" (soap-namespace-name ns) wsdl))
-
- ;; Add the soapenc types to the wsdl document
- (let ((ns (soap-default-soapenc-types)))
- (soap-wsdl-add-namespace ns wsdl)
- (soap-wsdl-add-alias "soapenc" (soap-namespace-name ns) wsdl))
-
- ;; Find all the 'xsd:schema nodes which are children of wsdl:types nodes
- ;; and build our type-library
-
- (let ((types (car (soap-xml-get-children1 node 'wsdl:types))))
- (dolist (node (xml-node-children types))
- ;; We cannot use (xml-get-children node (soap-wk2l 'xsd:schema))
- ;; because each node can install its own alias type so the schema
- ;; nodes might have a different prefix.
- (when (consp node)
- (soap-with-local-xmlns node
- (when (eq (soap-l2wk (xml-node-name node)) 'xsd:schema)
- (soap-wsdl-add-namespace (soap-parse-schema node) wsdl))))))
-
- (let ((ns (make-soap-namespace :name (soap-get-target-namespace node))))
- (dolist (node (soap-xml-get-children1 node 'wsdl:message))
- (soap-namespace-put (soap-parse-message node) ns))
-
- (dolist (node (soap-xml-get-children1 node 'wsdl:portType))
- (let ((port-type (soap-parse-port-type node)))
- (soap-namespace-put port-type ns)
- (soap-wsdl-add-namespace
- (soap-port-type-operations port-type) wsdl)))
-
- (dolist (node (soap-xml-get-children1 node 'wsdl:binding))
- (soap-namespace-put (soap-parse-binding node) ns))
-
- (dolist (node (soap-xml-get-children1 node 'wsdl:service))
- (dolist (node (soap-xml-get-children1 node 'wsdl:port))
- (let ((name (xml-get-attribute node 'name))
- (binding (xml-get-attribute node 'binding))
- (url (let ((n (car (soap-xml-get-children1
- node 'wsdlsoap:address))))
- (xml-get-attribute n 'location))))
- (let ((port (make-soap-port
- :name name :binding (soap-l2fq binding 'tns)
- :service-url url)))
- (soap-namespace-put port ns)
- (push port (soap-wsdl-ports wsdl))))))
-
- (soap-wsdl-add-namespace ns wsdl))
-
- (soap-wsdl-resolve-references wsdl)
-
- wsdl)))
-
-(defun soap-parse-schema (node)
- "Parse a schema NODE.
-Return a SOAP-NAMESPACE containing the elements."
+(defun soap-parse-wsdl-phase-fetch-imports (node wsdl)
+ "Fetch and load files imported by NODE into WSDL."
(soap-with-local-xmlns node
- (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:schema)
- nil
- "soap-parse-schema: expecting an xsd:schema node, got %s"
- (soap-l2wk (xml-node-name node)))
- (let ((ns (make-soap-namespace :name (soap-get-target-namespace node))))
- ;; NOTE: we only extract the complexTypes from the schema, we wouldn't
- ;; know how to handle basic types beyond the built in ones anyway.
- (dolist (node (soap-xml-get-children1 node 'xsd:simpleType))
- (soap-namespace-put (soap-parse-simple-type node) ns))
-
- (dolist (node (soap-xml-get-children1 node 'xsd:complexType))
- (soap-namespace-put (soap-parse-complex-type node) ns))
+ (dolist (node (soap-xml-get-children1 node 'wsdl:import))
+ (let ((location (xml-get-attribute-or-nil node 'location)))
+ (when location
+ (soap-load-wsdl location wsdl))))))
- (dolist (node (soap-xml-get-children1 node 'xsd:element))
- (soap-namespace-put (soap-parse-schema-element node) ns))
-
- ns)))
-
-(defun soap-parse-simple-type (node)
- "Parse NODE and construct a simple type from it."
- (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:simpleType)
- nil
- "soap-parse-complex-type: expecting xsd:simpleType node, got %s"
- (soap-l2wk (xml-node-name node)))
- (let ((name (xml-get-attribute-or-nil node 'name))
- type
- enumeration
- (restriction (car-safe
- (soap-xml-get-children1 node 'xsd:restriction))))
- (unless restriction
- (error "simpleType %s has no base type" name))
-
- (setq type (xml-get-attribute-or-nil restriction 'base))
- (dolist (e (soap-xml-get-children1 restriction 'xsd:enumeration))
- (push (xml-get-attribute e 'value) enumeration))
-
- (make-soap-simple-type :name name :kind type :enumeration enumeration)))
-
-(defun soap-parse-schema-element (node)
- "Parse NODE and construct a schema element from it."
- (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:element)
- nil
- "soap-parse-schema-element: expecting xsd:element node, got %s"
- (soap-l2wk (xml-node-name node)))
- (let ((name (xml-get-attribute-or-nil node 'name))
- type)
- ;; A schema element that contains an inline complex type --
- ;; construct the actual complex type for it.
- (let ((type-node (soap-xml-get-children1 node 'xsd:complexType)))
- (when (> (length type-node) 0)
- (assert (= (length type-node) 1)) ; only one complex type
- ; definition per element
- (setq type (soap-parse-complex-type (car type-node)))))
- (setf (soap-element-name type) name)
- type))
-
-(defun soap-parse-complex-type (node)
- "Parse NODE and construct a complex type from it."
- (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:complexType)
- nil
- "soap-parse-complex-type: expecting xsd:complexType node, got %s"
- (soap-l2wk (xml-node-name node)))
- (let ((name (xml-get-attribute-or-nil node 'name))
- ;; Use a dummy type for the complex type, it will be replaced
- ;; with the real type below, except when the complex type node
- ;; is empty...
- (type (make-soap-sequence-type :elements nil)))
- (dolist (c (xml-node-children node))
- (when (consp c) ; skip string nodes, which are whitespace
- (let ((node-name (soap-l2wk (xml-node-name c))))
- (cond
- ;; The difference between xsd:all and xsd:sequence is that fields
- ;; in xsd:all are not ordered and they can occur only once. We
- ;; don't care about that difference in soap-client.el
- ((or (eq node-name 'xsd:sequence)
- (eq node-name 'xsd:all))
- (setq type (soap-parse-complex-type-sequence c)))
- ((eq node-name 'xsd:complexContent)
- (setq type (soap-parse-complex-type-complex-content c)))
- ((eq node-name 'xsd:attribute)
- ;; The name of this node comes from an attribute tag
- (let ((n (xml-get-attribute-or-nil c 'name)))
- (setq name n)))
- (t
- (error "Unknown node type %s" node-name))))))
- (setf (soap-element-name type) name)
- type))
-
-(defun soap-parse-sequence (node)
- "Parse NODE and a list of sequence elements that it defines.
-NODE is assumed to be an xsd:sequence node. In that case, each
-of its children is assumed to be a sequence element. Each
-sequence element is parsed constructing the corresponding type.
-A list of these types is returned."
- (assert (let ((n (soap-l2wk (xml-node-name node))))
- (memq n '(xsd:sequence xsd:all)))
- nil
- "soap-parse-sequence: expecting xsd:sequence or xsd:all node, got %s"
- (soap-l2wk (xml-node-name node)))
- (let (elements)
- (dolist (e (soap-xml-get-children1 node 'xsd:element))
- (let ((name (xml-get-attribute-or-nil e 'name))
- (type (xml-get-attribute-or-nil e 'type))
- (nillable? (or (equal (xml-get-attribute-or-nil e 'nillable)
"true")
- (let ((e (xml-get-attribute-or-nil e 'minOccurs)))
- (and e (equal e "0")))))
- (multiple? (let ((e (xml-get-attribute-or-nil e 'maxOccurs)))
- (and e (not (equal e "1"))))))
- (if type
- (setq type (soap-l2fq type 'tns))
-
- ;; The node does not have a type, maybe it has a complexType
- ;; defined inline...
- (let ((type-node (soap-xml-get-children1 e 'xsd:complexType)))
- (when (> (length type-node) 0)
- (assert (= (length type-node) 1)
- nil
- "only one complex type definition per element
supported")
- (setq type (soap-parse-complex-type (car type-node))))))
-
- (push (make-soap-sequence-element
- :name (intern name) :type type :nillable? nillable?
- :multiple? multiple?)
- elements)))
- (nreverse elements)))
-
-(defun soap-parse-complex-type-sequence (node)
- "Parse NODE as a sequence type."
- (let ((elements (soap-parse-sequence node)))
- (make-soap-sequence-type :elements elements)))
-
-(defun soap-parse-complex-type-complex-content (node)
- "Parse NODE as a xsd:complexContent node.
-A sequence or an array type is returned depending on the actual
-contents."
- (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:complexContent)
- nil
- "soap-parse-complex-type-complex-content: expecting
xsd:complexContent node, got %s"
- (soap-l2wk (xml-node-name node)))
- (let (array? parent elements)
- (let ((extension (car-safe (soap-xml-get-children1 node 'xsd:extension)))
- (restriction (car-safe
- (soap-xml-get-children1 node 'xsd:restriction))))
- ;; a complex content node is either an extension or a restriction
- (cond (extension
- (setq parent (xml-get-attribute-or-nil extension 'base))
- (setq elements (soap-parse-sequence
- (car (soap-xml-get-children1
- extension 'xsd:sequence)))))
- (restriction
- (let ((base (xml-get-attribute-or-nil restriction 'base)))
- (assert (equal base (soap-wk2l "soapenc:Array"))
- nil
- "restrictions supported only for soapenc:Array types,
this is a %s"
- base))
- (setq array? t)
- (let ((attribute (car (soap-xml-get-children1
- restriction 'xsd:attribute))))
- (let ((array-type (soap-xml-get-attribute-or-nil1
- attribute 'wsdl:arrayType)))
- (when (string-match "^\\(.*\\)\\[\\]$" array-type)
- (setq parent (match-string 1 array-type))))))
-
- (t
- (error "Unknown complex type"))))
-
- (if parent
- (setq parent (soap-l2fq parent 'tns)))
+(defun soap-parse-wsdl-phase-parse-schema (node wsdl)
+ "Load types found in NODE into WSDL."
+ (soap-with-local-xmlns node
+ ;; Find all the 'xsd:schema nodes which are children of wsdl:types nodes
and
+ ;; build our type-library.
+ (let ((types (car (soap-xml-get-children1 node 'wsdl:types))))
+ (dolist (node (xml-node-children types))
+ ;; We cannot use (xml-get-children node (soap-wk2l 'xsd:schema))
because
+ ;; each node can install its own alias type so the schema nodes might
+ ;; have a different prefix.
+ (when (consp node)
+ (soap-with-local-xmlns
+ node
+ (when (eq (soap-l2wk (xml-node-name node)) 'xsd:schema)
+ (soap-wsdl-add-namespace (soap-parse-schema node wsdl)
+ wsdl))))))))
+
+(defun soap-parse-wsdl-phase-fetch-schema (node wsdl)
+ "Fetch and load schema imports defined by NODE into WSDL."
+ (soap-with-local-xmlns node
+ (while (soap-wsdl-xmlschema-imports wsdl)
+ (let* ((import (pop (soap-wsdl-xmlschema-imports wsdl)))
+ (xml (soap-fetch-xml import wsdl)))
+ (soap-wsdl-add-namespace (soap-parse-schema xml wsdl) wsdl)))))
- (if array?
- (make-soap-array-type :element-type parent)
- (make-soap-sequence-type :parent parent :elements elements))))
+(defun soap-parse-wsdl-phase-finish-parsing (node wsdl)
+ "Finish parsing NODE into WSDL."
+ (soap-with-local-xmlns node
+ (let ((ns (make-soap-namespace :name (soap-get-target-namespace node))))
+ (dolist (node (soap-xml-get-children1 node 'wsdl:message))
+ (soap-namespace-put (soap-parse-message node) ns))
+
+ (dolist (node (soap-xml-get-children1 node 'wsdl:portType))
+ (let ((port-type (soap-parse-port-type node)))
+ (soap-namespace-put port-type ns)
+ (soap-wsdl-add-namespace
+ (soap-port-type-operations port-type) wsdl)))
+
+ (dolist (node (soap-xml-get-children1 node 'wsdl:binding))
+ (soap-namespace-put (soap-parse-binding node) ns))
+
+ (dolist (node (soap-xml-get-children1 node 'wsdl:service))
+ (dolist (node (soap-xml-get-children1 node 'wsdl:port))
+ (let ((name (xml-get-attribute node 'name))
+ (binding (xml-get-attribute node 'binding))
+ (url (let ((n (car (soap-xml-get-children1
+ node 'wsdlsoap:address))))
+ (xml-get-attribute n 'location))))
+ (let ((port (make-soap-port
+ :name name :binding (soap-l2fq binding 'tns)
+ :service-url url)))
+ (soap-namespace-put port ns)
+ (push port (soap-wsdl-ports wsdl))))))
+
+ (soap-wsdl-add-namespace ns wsdl))))
+
+(defun soap-parse-wsdl (node wsdl)
+ "Construct from NODE a WSDL structure, which is an XML document."
+ ;; Break this into phases to allow for asynchronous parsing.
+ (soap-parse-wsdl-phase-validate-node node)
+ ;; Makes synchronous calls.
+ (soap-parse-wsdl-phase-fetch-imports node wsdl)
+ (soap-parse-wsdl-phase-parse-schema node wsdl)
+ ;; Makes synchronous calls.
+ (soap-parse-wsdl-phase-fetch-schema node wsdl)
+ (soap-parse-wsdl-phase-finish-parsing node wsdl)
+ wsdl)
(defun soap-parse-message (node)
"Parse NODE as a wsdl:message and return the corresponding type."
(assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:message)
nil
- "soap-parse-message: expecting wsdl:message node, got %s"
+ "expecting wsdl:message node, got %s"
(soap-l2wk (xml-node-name node)))
(let ((name (xml-get-attribute-or-nil node 'name))
parts)
@@ -1062,97 +2485,111 @@ contents."
(when type
(setq type (soap-l2fq type 'tns)))
- (when element
- (setq element (soap-l2fq element 'tns)))
+ (if element
+ (setq element (soap-l2fq element 'tns))
+ ;; else
+ (setq element (make-soap-xs-element
+ :name name
+ :namespace-tag soap-target-xmlns
+ :type^ type)))
- (push (cons name (or type element)) parts)))
+ (push (cons name element) parts)))
(make-soap-message :name name :parts (nreverse parts))))
(defun soap-parse-port-type (node)
"Parse NODE as a wsdl:portType and return the corresponding port."
(assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:portType)
nil
- "soap-parse-port-type: expecting wsdl:portType node got %s"
+ "expecting wsdl:portType node got %s"
(soap-l2wk (xml-node-name node)))
- (let ((ns (make-soap-namespace
- :name (concat "urn:" (xml-get-attribute node 'name)))))
+ (let* ((soap-target-xmlns (concat "urn:" (xml-get-attribute node 'name)))
+ (ns (make-soap-namespace :name soap-target-xmlns)))
(dolist (node (soap-xml-get-children1 node 'wsdl:operation))
(let ((o (soap-parse-operation node)))
(let ((other-operation (soap-namespace-get
- (soap-element-name o) ns 'soap-operation-p)))
+ (soap-element-name o) ns 'soap-operation-p)))
(if other-operation
;; Unfortunately, the Confluence WSDL defines two operations
;; named "search" which differ only in parameter names...
(soap-warning "Discarding duplicate operation: %s"
- (soap-element-name o))
+ (soap-element-name o))
- (progn
- (soap-namespace-put o ns)
+ (progn
+ (soap-namespace-put o ns)
- ;; link all messages from this namespace, as this namespace
- ;; will be used for decoding the response.
- (destructuring-bind (name . message) (soap-operation-input o)
- (soap-namespace-put-link name message ns))
+ ;; link all messages from this namespace, as this namespace
+ ;; will be used for decoding the response.
+ (destructuring-bind (name . message) (soap-operation-input o)
+ (soap-namespace-put-link name message ns))
- (destructuring-bind (name . message) (soap-operation-output o)
- (soap-namespace-put-link name message ns))
+ (destructuring-bind (name . message) (soap-operation-output o)
+ (soap-namespace-put-link name message ns))
- (dolist (fault (soap-operation-faults o))
- (destructuring-bind (name . message) fault
- (soap-namespace-put-link name message ns 'replace)))
+ (dolist (fault (soap-operation-faults o))
+ (destructuring-bind (name . message) fault
+ (soap-namespace-put-link name message ns)))
- )))))
+ )))))
(make-soap-port-type :name (xml-get-attribute node 'name)
- :operations ns)))
+ :operations ns)))
(defun soap-parse-operation (node)
"Parse NODE as a wsdl:operation and return the corresponding type."
(assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:operation)
nil
- "soap-parse-operation: expecting wsdl:operation node, got %s"
+ "expecting wsdl:operation node, got %s"
(soap-l2wk (xml-node-name node)))
(let ((name (xml-get-attribute node 'name))
(parameter-order (split-string
- (xml-get-attribute node 'parameterOrder)))
- input output faults)
+ (xml-get-attribute node 'parameterOrder)))
+ input output faults input-action output-action)
(dolist (n (xml-node-children node))
(when (consp n) ; skip string nodes which are whitespace
(let ((node-name (soap-l2wk (xml-node-name n))))
(cond
- ((eq node-name 'wsdl:input)
- (let ((message (xml-get-attribute n 'message))
- (name (xml-get-attribute n 'name)))
- (setq input (cons name (soap-l2fq message 'tns)))))
- ((eq node-name 'wsdl:output)
- (let ((message (xml-get-attribute n 'message))
- (name (xml-get-attribute n 'name)))
- (setq output (cons name (soap-l2fq message 'tns)))))
- ((eq node-name 'wsdl:fault)
- (let ((message (xml-get-attribute n 'message))
- (name (xml-get-attribute n 'name)))
- (push (cons name (soap-l2fq message 'tns)) faults)))))))
+ ((eq node-name 'wsdl:input)
+ (let ((message (xml-get-attribute n 'message))
+ (name (xml-get-attribute n 'name))
+ (action (soap-xml-get-attribute-or-nil1 n 'wsaw:Action)))
+ (setq input (cons name (soap-l2fq message 'tns)))
+ (setq input-action action)))
+ ((eq node-name 'wsdl:output)
+ (let ((message (xml-get-attribute n 'message))
+ (name (xml-get-attribute n 'name))
+ (action (soap-xml-get-attribute-or-nil1 n 'wsaw:Action)))
+ (setq output (cons name (soap-l2fq message 'tns)))
+ (setq output-action action)))
+ ((eq node-name 'wsdl:fault)
+ (let ((message (xml-get-attribute n 'message))
+ (name (xml-get-attribute n 'name)))
+ (push (cons name (soap-l2fq message 'tns)) faults)))))))
(make-soap-operation
:name name
+ :namespace-tag soap-target-xmlns
:parameter-order parameter-order
:input input
:output output
- :faults (nreverse faults))))
+ :faults (nreverse faults)
+ :input-action input-action
+ :output-action output-action)))
(defun soap-parse-binding (node)
"Parse NODE as a wsdl:binding and return the corresponding type."
(assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:binding)
nil
- "soap-parse-binding: expecting wsdl:binding node, got %s"
+ "expecting wsdl:binding node, got %s"
(soap-l2wk (xml-node-name node)))
(let ((name (xml-get-attribute node 'name))
(type (xml-get-attribute node 'type)))
(let ((binding (make-soap-binding :name name
- :port-type (soap-l2fq type 'tns))))
+ :port-type (soap-l2fq type 'tns))))
(dolist (wo (soap-xml-get-children1 node 'wsdl:operation))
(let ((name (xml-get-attribute wo 'name))
soap-action
+ soap-headers
+ soap-body
use)
(dolist (so (soap-xml-get-children1 wo 'wsdlsoap:operation))
(setq soap-action (xml-get-attribute-or-nil so 'soapAction)))
@@ -1163,9 +2600,24 @@ contents."
;; "use"-s for each of them...
(dolist (i (soap-xml-get-children1 wo 'wsdl:input))
- (dolist (b (soap-xml-get-children1 i 'wsdlsoap:body))
- (setq use (or use
- (xml-get-attribute-or-nil b 'use)))))
+
+ ;; There can be multiple headers ...
+ (dolist (h (soap-xml-get-children1 i 'wsdlsoap:header))
+ (let ((message (soap-l2fq (xml-get-attribute-or-nil h 'message)))
+ (part (xml-get-attribute-or-nil h 'part))
+ (use (xml-get-attribute-or-nil h 'use)))
+ (when (and message part)
+ (push (list message part use) soap-headers))))
+
+ ;; ... but only one body
+ (let ((body (car (soap-xml-get-children1 i 'wsdlsoap:body))))
+ (setq soap-body (xml-get-attribute-or-nil body 'parts))
+ (when soap-body
+ (setq soap-body
+ (mapcar #'intern (split-string soap-body
+ nil
+ 'omit-nulls))))
+ (setq use (xml-get-attribute-or-nil body 'use))))
(unless use
(dolist (i (soap-xml-get-children1 wo 'wsdl:output))
@@ -1173,9 +2625,12 @@ contents."
(setq use (or use
(xml-get-attribute-or-nil b 'use))))))
- (puthash name (make-soap-bound-operation :operation name
- :soap-action soap-action
- :use (and use (intern use)))
+ (puthash name (make-soap-bound-operation
+ :operation name
+ :soap-action soap-action
+ :soap-headers (nreverse soap-headers)
+ :soap-body soap-body
+ :use (and use (intern use)))
(soap-binding-operations binding))))
binding)))
@@ -1191,10 +2646,6 @@ SOAP response.")
This is a dynamically bound variable used during decoding the
SOAP response.")
-(defvar soap-current-wsdl nil
- "The current WSDL document used when decoding the SOAP response.
-This is a dynamically bound variable.")
-
(defun soap-decode-type (type node)
"Use TYPE (an xsd type) to decode the contents of NODE.
@@ -1212,7 +2663,8 @@ decode function to perform the actual decoding."
(when decoded
(throw 'done decoded)))
- (string-match "^#\\(.*\\)$" href) ; TODO: check that it matched
+ (unless (string-match "^#\\(.*\\)$" href)
+ (error "Invalid multiRef: %s" href))
(let ((id (match-string 1 href)))
(dolist (mr soap-multi-refs)
@@ -1227,38 +2679,53 @@ decode function to perform the actual decoding."
(soap-with-local-xmlns node
(if (equal (soap-xml-get-attribute-or-nil1 node 'xsi:nil) "true")
nil
- (let ((decoder (get (aref type 0) 'soap-decoder)))
- (assert decoder nil "no soap-decoder for %s type"
- (aref type 0))
- (funcall decoder type node))))))))
+ ;; Handle union types.
+ (cond ((listp type)
+ (catch 'done
+ (dolist (union-member type)
+ (let* ((decoder (get (aref union-member 0)
+ 'soap-decoder))
+ (result (ignore-errors
+ (funcall decoder
+ union-member node))))
+ (when result (throw 'done result))))))
+ (t
+ (let ((decoder (get (aref type 0) 'soap-decoder)))
+ (assert decoder nil
+ "no soap-decoder for %s type" (aref type 0))
+ (funcall decoder type node))))))))))
(defun soap-decode-any-type (node)
"Decode NODE using type information inside it."
;; If the NODE has type information, we use that...
(let ((type (soap-xml-get-attribute-or-nil1 node 'xsi:type)))
+ (when type
+ (setq type (soap-l2fq type)))
(if type
- (let ((wtype (soap-wsdl-get type soap-current-wsdl 'soap-type-p)))
+ (let ((wtype (soap-wsdl-get type soap-current-wsdl 'soap-xs-type-p)))
(if wtype
(soap-decode-type wtype node)
- ;; The node has type info encoded in it, but we don't know how
- ;; to decode it...
- (error "Soap-decode-any-type: node has unknown type: %s" type)))
-
- ;; No type info in the node...
-
- (let ((contents (xml-node-children node)))
- (if (and (= (length contents) 1) (stringp (car contents)))
- ;; contents is just a string
- (car contents)
-
- ;; we assume the NODE is a sequence with every element a
- ;; structure name
- (let (result)
- (dolist (element contents)
- (let ((key (xml-node-name element))
- (value (soap-decode-any-type element)))
- (push (cons key value) result)))
- (nreverse result)))))))
+ ;; The node has type info encoded in it, but we don't know how
+ ;; to decode it...
+ (error "Node has unknown type: %s" type)))
+
+ ;; No type info in the node...
+
+ (let ((contents (xml-node-children node)))
+ (if (and (= (length contents) 1) (stringp (car contents)))
+ ;; contents is just a string
+ (car contents)
+
+ ;; we assume the NODE is a sequence with every element a
+ ;; structure name
+ (let (result)
+ (dolist (element contents)
+ ;; skip any string contents, assume they are whitespace
+ (unless (stringp element)
+ (let ((key (xml-node-name element))
+ (value (soap-decode-any-type element)))
+ (push (cons key value) result))))
+ (nreverse result)))))))
(defun soap-decode-array (node)
"Decode NODE as an Array using type information inside it."
@@ -1267,90 +2734,23 @@ decode function to perform the actual decoding."
(contents (xml-node-children node))
result)
(when type
- ;; Type is in the format "someType[NUM]" where NUM is the number of
- ;; elements in the array. We discard the [NUM] part.
- (setq type (replace-regexp-in-string "\\[[0-9]+\\]\\'" "" type))
- (setq wtype (soap-wsdl-get type soap-current-wsdl 'soap-type-p))
- (unless wtype
- ;; The node has type info encoded in it, but we don't know how to
- ;; decode it...
- (error "Soap-decode-array: node has unknown type: %s" type)))
+ ;; Type is in the format "someType[NUM]" where NUM is the number of
+ ;; elements in the array. We discard the [NUM] part.
+ (setq type (replace-regexp-in-string "\\[[0-9]+\\]\\'" "" type))
+ (setq wtype (soap-wsdl-get (soap-l2fq type)
+ soap-current-wsdl 'soap-xs-type-p))
+ (unless wtype
+ ;; The node has type info encoded in it, but we don't know how to
+ ;; decode it...
+ (error "Soap-decode-array: node has unknown type: %s" type)))
(dolist (e contents)
(when (consp e)
(push (if wtype
(soap-decode-type wtype e)
- (soap-decode-any-type e))
+ (soap-decode-any-type e))
result)))
(nreverse result)))
-(defun soap-decode-basic-type (type node)
- "Use TYPE to decode the contents of NODE.
-TYPE is a `soap-basic-type' struct, and NODE is an XML document.
-A LISP value is returned based on the contents of NODE and the
-type-info stored in TYPE."
- (let ((contents (xml-node-children node))
- (type-kind (soap-basic-type-kind type)))
-
- (if (null contents)
- nil
- (ecase type-kind
- ((string anyURI) (car contents))
- (dateTime (car contents)) ; TODO: convert to a date time
- ((long int integer unsignedInt byte float double) (string-to-number
(car contents)))
- (boolean (string= (downcase (car contents)) "true"))
- (base64Binary (base64-decode-string (car contents)))
- (anyType (soap-decode-any-type node))
- (Array (soap-decode-array node))))))
-
-(defun soap-decode-sequence-type (type node)
- "Use TYPE to decode the contents of NODE.
-TYPE is assumed to be a sequence type and an ALIST with the
-contents of the NODE is returned."
- (let ((result nil)
- (parent (soap-sequence-type-parent type)))
- (when parent
- (setq result (nreverse (soap-decode-type parent node))))
- (dolist (element (soap-sequence-type-elements type))
- (let ((instance-count 0)
- (e-name (soap-sequence-element-name element))
- (e-type (soap-sequence-element-type element)))
- (dolist (node (xml-get-children node e-name))
- (incf instance-count)
- (push (cons e-name (soap-decode-type e-type node)) result))
- ;; Do some sanity checking
- (cond ((and (= instance-count 0)
- (not (soap-sequence-element-nillable? element)))
- (soap-warning "While decoding %s: missing non-nillable slot %s"
- (soap-element-name type) e-name))
- ((and (> instance-count 1)
- (not (soap-sequence-element-multiple? element)))
- (soap-warning "While decoding %s: multiple slots named %s"
- (soap-element-name type) e-name)))))
- (nreverse result)))
-
-(defun soap-decode-array-type (type node)
- "Use TYPE to decode the contents of NODE.
-TYPE is assumed to be an array type. Arrays are decoded as lists.
-This is because it is easier to work with list results in LISP."
- (let ((result nil)
- (element-type (soap-array-type-element-type type)))
- (dolist (node (xml-node-children node))
- (when (consp node)
- (push (soap-decode-type element-type node) result)))
- (nreverse result)))
-
-(progn
- (put (aref (make-soap-basic-type) 0)
- 'soap-decoder 'soap-decode-basic-type)
- ;; just use the basic type decoder for the simple type -- we accept any
- ;; value and don't do any validation on it.
- (put (aref (make-soap-simple-type) 0)
- 'soap-decoder 'soap-decode-basic-type)
- (put (aref (make-soap-sequence-type) 0)
- 'soap-decoder 'soap-decode-sequence-type)
- (put (aref (make-soap-array-type) 0)
- 'soap-decoder 'soap-decode-array-type))
-
;;;; Soap Envelope parsing
(define-error 'soap-error "SOAP error")
@@ -1362,40 +2762,44 @@ WSDL is used to decode the NODE"
(soap-with-local-xmlns node
(assert (eq (soap-l2wk (xml-node-name node)) 'soap:Envelope)
nil
- "soap-parse-envelope: expecting soap:Envelope node, got %s"
+ "expecting soap:Envelope node, got %s"
(soap-l2wk (xml-node-name node)))
- (let ((body (car (soap-xml-get-children1 node 'soap:Body))))
+ (let ((headers (soap-xml-get-children1 node 'soap:Header))
+ (body (car (soap-xml-get-children1 node 'soap:Body))))
(let ((fault (car (soap-xml-get-children1 body 'soap:Fault))))
(when fault
(let ((fault-code (let ((n (car (xml-get-children
- fault 'faultcode))))
+ fault 'faultcode))))
(car-safe (xml-node-children n))))
(fault-string (let ((n (car (xml-get-children
fault 'faultstring))))
(car-safe (xml-node-children n))))
(detail (xml-get-children fault 'detail)))
- (while t
- (signal 'soap-error (list fault-code fault-string detail))))))
+ (while t
+ (signal 'soap-error (list fault-code fault-string detail))))))
;; First (non string) element of the body is the root node of he
;; response
(let ((response (if (eq (soap-bound-operation-use operation) 'literal)
;; For 'literal uses, the response is the actual body
body
- ;; ...otherwise the first non string element
- ;; of the body is the response
- (catch 'found
- (dolist (n (xml-node-children body))
- (when (consp n)
- (throw 'found n)))))))
- (soap-parse-response response operation wsdl body)))))
-
-(defun soap-parse-response (response-node operation wsdl soap-body)
+ ;; ...otherwise the first non string element
+ ;; of the body is the response
+ (catch 'found
+ (dolist (n (xml-node-children body))
+ (when (consp n)
+ (throw 'found n)))))))
+ (soap-parse-response response operation wsdl headers body)))))
+
+(defun soap-parse-response (response-node operation wsdl soap-headers
soap-body)
"Parse RESPONSE-NODE and return the result as a LISP value.
OPERATION is the WSDL operation for which we expect the response,
WSDL is used to decode the NODE.
+SOAP-HEADERS is a list of the headers of the SOAP envelope or nil
+if there are no headers.
+
SOAP-BODY is the body of the SOAP envelope (of which
RESPONSE-NODE is a sub-node). It is used in case RESPONSE-NODE
reference multiRef parts which are external to RESPONSE-NODE."
@@ -1409,7 +2813,7 @@ reference multiRef parts which are external to
RESPONSE-NODE."
(when (eq use 'encoded)
(let* ((received-message-name (soap-l2fq (xml-node-name
response-node)))
(received-message (soap-wsdl-get
- received-message-name wsdl 'soap-message-p)))
+ received-message-name wsdl 'soap-message-p)))
(unless (eq received-message message)
(error "Unexpected message: got %s, expecting %s"
received-message-name
@@ -1426,42 +2830,52 @@ reference multiRef parts which are external to
RESPONSE-NODE."
(setq node
(cond
- ((eq use 'encoded)
- (car (xml-get-children response-node tag)))
-
- ((eq use 'literal)
- (catch 'found
- (let* ((ns-aliases (soap-wsdl-alias-table wsdl))
- (ns-name (cdr (assoc
- (soap-element-namespace-tag type)
- ns-aliases)))
- (fqname (cons ns-name (soap-element-name type))))
- (dolist (c (xml-node-children response-node))
- (when (consp c)
- (soap-with-local-xmlns c
- (when (equal (soap-l2fq (xml-node-name c))
- fqname)
- (throw 'found c))))))))))
+ ((eq use 'encoded)
+ (car (xml-get-children response-node tag)))
+
+ ((eq use 'literal)
+ (catch 'found
+ (let* ((ns-aliases (soap-wsdl-alias-table wsdl))
+ (ns-name (cdr (assoc
+ (soap-element-namespace-tag type)
+ ns-aliases)))
+ (fqname (cons ns-name (soap-element-name type))))
+ (dolist (c (append (mapcar (lambda (header)
+ (car (xml-node-children
+ header)))
+ soap-headers)
+ (xml-node-children response-node)))
+ (when (consp c)
+ (soap-with-local-xmlns c
+ (when (equal (soap-l2fq (xml-node-name c))
+ fqname)
+ (throw 'found c))))))))))
(unless node
(error "Soap-parse-response(%s): cannot find message part %s"
(soap-element-name op) tag))
- (push (soap-decode-type type node) decoded-parts)))
+ (let ((decoded-value (soap-decode-type type node)))
+ (when decoded-value
+ (push decoded-value decoded-parts)))))
decoded-parts))))
;;;; SOAP type encoding
-(defvar soap-encoded-namespaces nil
- "A list of namespace tags used during encoding a message.
-This list is populated by `soap-encode-value' and used by
-`soap-create-envelope' to add aliases for these namespace to the
-XML request.
+(defun soap-encode-attributes (value type)
+ "Encode XML attributes for VALUE according to TYPE.
+This is a generic function which determines the attribute encoder
+for the type and calls that specialized function to do the work.
-This variable is dynamically bound in `soap-create-envelope'.")
+Attributes are inserted in the current buffer at the current
+position."
+ (let ((attribute-encoder (get (aref type 0) 'soap-attribute-encoder)))
+ (assert attribute-encoder nil
+ "no soap-attribute-encoder for %s type" (aref type 0))
+ (funcall attribute-encoder value type)))
-(defun soap-encode-value (xml-tag value type)
- "Encode inside an XML-TAG the VALUE using TYPE.
+(defun soap-encode-value (value type)
+ "Encode the VALUE using TYPE.
The resulting XML data is inserted in the current buffer
at (point)/
@@ -1471,190 +2885,24 @@ encoder function based on TYPE and calls that encoder
to do the
work."
(let ((encoder (get (aref type 0) 'soap-encoder)))
(assert encoder nil "no soap-encoder for %s type" (aref type 0))
- ;; XML-TAG can be a string or a symbol, but we pass only string's to the
- ;; encoders
- (when (symbolp xml-tag)
- (setq xml-tag (symbol-name xml-tag)))
- (funcall encoder xml-tag value type))
- (add-to-list 'soap-encoded-namespaces (soap-element-namespace-tag type)))
-
-(defun soap-encode-basic-type (xml-tag value type)
- "Encode inside XML-TAG the LISP VALUE according to TYPE.
-Do not call this function directly, use `soap-encode-value'
-instead."
- (let ((xsi-type (soap-element-fq-name type))
- (basic-type (soap-basic-type-kind type)))
-
- ;; try to classify the type based on the value type and use that type when
- ;; encoding
- (when (eq basic-type 'anyType)
- (cond ((stringp value)
- (setq xsi-type "xsd:string" basic-type 'string))
- ((integerp value)
- (setq xsi-type "xsd:int" basic-type 'int))
- ((memq value '(t nil))
- (setq xsi-type "xsd:boolean" basic-type 'boolean))
- (t
- (error
- "Soap-encode-basic-type(%s, %s, %s): cannot classify anyType
value"
- xml-tag value xsi-type))))
+ (funcall encoder value type))
+ (when (soap-element-namespace-tag type)
+ (add-to-list 'soap-encoded-namespaces (soap-element-namespace-tag type))))
- (insert "<" xml-tag " xsi:type=\"" xsi-type "\"")
-
- ;; We have some ambiguity here, as a nil value represents "false" when the
- ;; type is boolean, we will never have a "nil" boolean type...
-
- (if (or value (eq basic-type 'boolean))
- (progn
- (insert ">")
- (case basic-type
- ((string anyURI)
- (unless (stringp value)
- (error "Soap-encode-basic-type(%s, %s, %s): not a string value"
- xml-tag value xsi-type))
- (insert (url-insert-entities-in-string value)))
-
- (dateTime
- (cond ((and (consp value) ; is there a time-value-p ?
- (>= (length value) 2)
- (numberp (nth 0 value))
- (numberp (nth 1 value)))
- ;; Value is a (current-time) style value, convert
- ;; to a string
- (insert (format-time-string "%Y-%m-%dT%H:%M:%S" value)))
- ((stringp value)
- (insert (url-insert-entities-in-string value)))
- (t
- (error
- "Soap-encode-basic-type(%s, %s, %s): not a dateTime value"
- xml-tag value xsi-type))))
-
- (boolean
- (unless (memq value '(t nil))
- (error "Soap-encode-basic-type(%s, %s, %s): not a boolean value"
- xml-tag value xsi-type))
- (insert (if value "true" "false")))
-
- ((long int integer byte unsignedInt)
- (unless (integerp value)
- (error "Soap-encode-basic-type(%s, %s, %s): not an integer
value"
- xml-tag value xsi-type))
- (when (and (eq basic-type 'unsignedInt) (< value 0))
- (error "Soap-encode-basic-type(%s, %s, %s): not a positive
integer"
- xml-tag value xsi-type))
- (insert (number-to-string value)))
-
- ((float double)
- (unless (numberp value)
- (error "Soap-encode-basic-type(%s, %s, %s): not a number"
- xml-tag value xsi-type))
- (insert (number-to-string value)))
-
- (base64Binary
- (unless (stringp value)
- (error "Soap-encode-basic-type(%s, %s, %s): not a string value"
- xml-tag value xsi-type))
- (insert (base64-encode-string value)))
-
- (otherwise
- (error
- "Soap-encode-basic-type(%s, %s, %s): don't know how to encode"
- xml-tag value xsi-type))))
-
- (insert " xsi:nil=\"true\">"))
- (insert "</" xml-tag ">\n")))
-
-(defun soap-encode-simple-type (xml-tag value type)
- "Encode inside XML-TAG the LISP VALUE according to TYPE."
-
- ;; Validate VALUE against the simple type's enumeration, than just encode it
- ;; using `soap-encode-basic-type'
-
- (let ((enumeration (soap-simple-type-enumeration type)))
- (unless (and (> (length enumeration) 1)
- (member value enumeration))
- (error "soap-encode-simple-type(%s, %s, %s): bad value, should be one of
%s"
- xml-tag value (soap-element-fq-name type) enumeration)))
-
- (soap-encode-basic-type xml-tag value type))
-
-(defun soap-encode-sequence-type (xml-tag value type)
- "Encode inside XML-TAG the LISP VALUE according to TYPE.
-Do not call this function directly, use `soap-encode-value'
-instead."
- (let ((xsi-type (soap-element-fq-name type)))
- (insert "<" xml-tag " xsi:type=\"" xsi-type "\"")
- (if value
- (progn
- (insert ">\n")
- (let ((parents (list type))
- (parent (soap-sequence-type-parent type)))
-
- (while parent
- (push parent parents)
- (setq parent (soap-sequence-type-parent parent)))
-
- (dolist (type parents)
- (dolist (element (soap-sequence-type-elements type))
- (let ((instance-count 0)
- (e-name (soap-sequence-element-name element))
- (e-type (soap-sequence-element-type element)))
- (dolist (v value)
- (when (equal (car v) e-name)
- (incf instance-count)
- (soap-encode-value e-name (cdr v) e-type)))
-
- ;; Do some sanity checking
- (cond ((and (= instance-count 0)
- (not (soap-sequence-element-nillable? element)))
- (soap-warning
- "While encoding %s: missing non-nillable slot %s"
- (soap-element-name type) e-name))
- ((and (> instance-count 1)
- (not (soap-sequence-element-multiple? element)))
- (soap-warning
- "While encoding %s: multiple slots named %s"
- (soap-element-name type) e-name))))))))
- (insert " xsi:nil=\"true\">"))
- (insert "</" xml-tag ">\n")))
-
-(defun soap-encode-array-type (xml-tag value type)
- "Encode inside XML-TAG the LISP VALUE according to TYPE.
-Do not call this function directly, use `soap-encode-value'
-instead."
- (unless (vectorp value)
- (error "Soap-encode: %s(%s) expects a vector, got: %s"
- xml-tag (soap-element-fq-name type) value))
- (let* ((element-type (soap-array-type-element-type type))
- (array-type (concat (soap-element-fq-name element-type)
- "[" (format "%s" (length value)) "]")))
- (insert "<" xml-tag
- " soapenc:arrayType=\"" array-type "\" "
- " xsi:type=\"soapenc:Array\">\n")
- (loop for i below (length value)
- do (soap-encode-value xml-tag (aref value i) element-type))
- (insert "</" xml-tag ">\n")))
-
-(progn
- (put (aref (make-soap-basic-type) 0)
- 'soap-encoder 'soap-encode-basic-type)
- (put (aref (make-soap-simple-type) 0)
- 'soap-encoder 'soap-encode-simple-type)
- (put (aref (make-soap-sequence-type) 0)
- 'soap-encoder 'soap-encode-sequence-type)
- (put (aref (make-soap-array-type) 0)
- 'soap-encoder 'soap-encode-array-type))
-
-(defun soap-encode-body (operation parameters wsdl)
+(defun soap-encode-body (operation parameters &optional service-url)
"Create the body of a SOAP request for OPERATION in the current buffer.
PARAMETERS is a list of parameters supplied to the OPERATION.
The OPERATION and PARAMETERS are encoded according to the WSDL
-document."
+document. SERVICE-URL should be provided when WS-Addressing is
+being used."
(let* ((op (soap-bound-operation-operation operation))
(use (soap-bound-operation-use operation))
(message (cdr (soap-operation-input op)))
- (parameter-order (soap-operation-parameter-order op)))
+ (parameter-order (soap-operation-parameter-order op))
+ (param-table (loop for formal in parameter-order
+ for value in parameters
+ collect (cons formal value))))
(unless (= (length parameter-order) (length parameters))
(error "Wrong number of parameters for %s: expected %d, got %s"
@@ -1662,62 +2910,73 @@ document."
(length parameter-order)
(length parameters)))
+ (let ((headers (soap-bound-operation-soap-headers operation))
+ (input-action (soap-operation-input-action op)))
+ (when headers
+ (insert "<soap:Header>\n")
+ (when input-action
+ (add-to-list 'soap-encoded-namespaces "wsa")
+ (insert "<wsa:Action>" input-action "</wsa:Action>\n")
+ (insert "<wsa:To>" service-url "</wsa:To>\n"))
+ (dolist (h headers)
+ (let* ((message (nth 0 h))
+ (part (assq (nth 1 h) (soap-message-parts message)))
+ (value (cdr (assoc (car part) (car parameters))))
+ (use (nth 2 h))
+ (element (cdr part)))
+ (when (eq use 'encoded)
+ (when (soap-element-namespace-tag element)
+ (add-to-list 'soap-encoded-namespaces
+ (soap-element-namespace-tag element)))
+ (insert "<" (soap-element-fq-name element) ">\n"))
+ (soap-encode-value value element)
+ (when (eq use 'encoded)
+ (insert "</" (soap-element-fq-name element) ">\n"))))
+ (insert "</soap:Header>\n")))
+
(insert "<soap:Body>\n")
(when (eq use 'encoded)
- (add-to-list 'soap-encoded-namespaces (soap-element-namespace-tag op))
+ (when (soap-element-namespace-tag op)
+ (add-to-list 'soap-encoded-namespaces (soap-element-namespace-tag op)))
(insert "<" (soap-element-fq-name op) ">\n"))
- (let ((param-table (loop for formal in parameter-order
- for value in parameters
- collect (cons formal value))))
- (dolist (part (soap-message-parts message))
- (let* ((param-name (car part))
- (type (cdr part))
- (tag-name (if (eq use 'encoded)
- param-name
- (soap-element-name type)))
- (value (cdr (assoc param-name param-table)))
- (start-pos (point)))
- (soap-encode-value tag-name value type)
- (when (eq use 'literal)
- ;; hack: add the xmlns attribute to the tag, the only way
- ;; ASP.NET web services recognize the namespace of the
- ;; element itself...
- (save-excursion
- (goto-char start-pos)
- (when (re-search-forward " ")
- (let* ((ns (soap-element-namespace-tag type))
- (namespace (cdr (assoc ns
- (soap-wsdl-alias-table wsdl)))))
- (when namespace
- (insert "xmlns=\"" namespace "\" ")))))))))
+ (dolist (part (soap-message-parts message))
+ (let* ((param-name (car part))
+ (element (cdr part))
+ (value (cdr (assoc param-name param-table))))
+ (when (or (null (soap-bound-operation-soap-body operation))
+ (member param-name
+ (soap-bound-operation-soap-body operation)))
+ (soap-encode-value value element))))
(when (eq use 'encoded)
(insert "</" (soap-element-fq-name op) ">\n"))
(insert "</soap:Body>\n")))
-(defun soap-create-envelope (operation parameters wsdl)
+(defun soap-create-envelope (operation parameters wsdl &optional service-url)
"Create a SOAP request envelope for OPERATION using PARAMETERS.
-WSDL is the wsdl document used to encode the PARAMETERS."
+WSDL is the wsdl document used to encode the PARAMETERS.
+SERVICE-URL should be provided when WS-Addressing is being used."
(with-temp-buffer
(let ((soap-encoded-namespaces '("xsi" "soap" "soapenc"))
(use (soap-bound-operation-use operation)))
;; Create the request body
- (soap-encode-body operation parameters wsdl)
+ (soap-encode-body operation parameters service-url)
;; Put the envelope around the body
(goto-char (point-min))
(insert "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<soap:Envelope\n")
(when (eq use 'encoded)
- (insert "
soapenc:encodingStyle=\"http://schemas.xmlsoap.org/soap/encoding/\"\n";))
+ (insert " soapenc:encodingStyle=\"\
+http://schemas.xmlsoap.org/soap/encoding/\"\n";))
(dolist (nstag soap-encoded-namespaces)
(insert " xmlns:" nstag "=\"")
(let ((nsname (cdr (assoc nstag soap-well-known-xmlns))))
(unless nsname
(setq nsname (cdr (assoc nstag (soap-wsdl-alias-table wsdl)))))
(insert nsname)
- (insert "\"\n")))
+ (insert "\"\n")))
(insert ">\n")
(goto-char (point-max))
(insert "</soap:Envelope>\n"))
@@ -1731,6 +2990,86 @@ WSDL is the wsdl document used to encode the PARAMETERS."
:type 'boolean
:group 'soap-client)
+(defun soap-invoke-internal (callback cbargs wsdl service operation-name
+ &rest parameters)
+ "Implement `soap-invoke' and `soap-invoke-async'.
+If CALLBACK is non-nil, operate asynchronously, then call CALLBACK as (apply
+CALLBACK RESPONSE CBARGS), where RESPONSE is the SOAP invocation result.
+If CALLBACK is nil, operate synchronously. WSDL, SERVICE,
+OPERATION-NAME and PARAMETERS are as described in `soap-invoke'."
+ (let ((port (catch 'found
+ (dolist (p (soap-wsdl-ports wsdl))
+ (when (equal service (soap-element-name p))
+ (throw 'found p))))))
+ (unless port
+ (error "Unknown SOAP service: %s" service))
+
+ (let* ((binding (soap-port-binding port))
+ (operation (gethash operation-name
+ (soap-binding-operations binding))))
+ (unless operation
+ (error "No operation %s for SOAP service %s" operation-name service))
+
+ (let ((url-request-method "POST")
+ (url-package-name "soap-client.el")
+ (url-package-version "1.0")
+ (url-request-data
+ ;; url-request-data expects a unibyte string already encoded...
+ (encode-coding-string
+ (soap-create-envelope operation parameters wsdl
+ (soap-port-service-url port))
+ 'utf-8))
+ (url-mime-charset-string "utf-8;q=1, iso-8859-1;q=0.5")
+ (url-http-attempt-keepalives t)
+ (url-request-extra-headers
+ (list
+ (cons "SOAPAction"
+ (concat "\"" (soap-bound-operation-soap-action
+ operation) "\""))
+ (cons "Content-Type"
+ "text/xml; charset=utf-8"))))
+ (if callback
+ (url-retrieve
+ (soap-port-service-url port)
+ (lambda (status)
+ (let ((data-buffer (current-buffer)))
+ (unwind-protect
+ (let ((error-status (plist-get status :error)))
+ (if error-status
+ (signal (car error-status) (cdr error-status))
+ (apply callback
+ (soap-parse-envelope
+ (soap-parse-server-response)
+ operation wsdl)
+ cbargs)))
+ ;; Ensure the url-retrieve buffer is not leaked.
+ (and (buffer-live-p data-buffer)
+ (kill-buffer data-buffer))))))
+ (let ((buffer (url-retrieve-synchronously
+ (soap-port-service-url port))))
+ (condition-case err
+ (with-current-buffer buffer
+ (declare (special url-http-response-status))
+ (if (null url-http-response-status)
+ (error "No HTTP response from server"))
+ (if (and soap-debug (> url-http-response-status 299))
+ ;; This is a warning because some SOAP errors come
+ ;; back with a HTTP response 500 (internal server
+ ;; error)
+ (warn "Error in SOAP response: HTTP code %s"
+ url-http-response-status))
+ (soap-parse-envelope (soap-parse-server-response)
+ operation wsdl))
+ (soap-error
+ ;; Propagate soap-errors -- they are error replies of the
+ ;; SOAP protocol and don't indicate a communication
+ ;; problem or a bug in this code.
+ (signal (car err) (cdr err)))
+ (error
+ (when soap-debug
+ (pop-to-buffer buffer))
+ (error (error-message-string err))))))))))
+
(defun soap-invoke (wsdl service operation-name &rest parameters)
"Invoke a SOAP operation and return the result.
@@ -1749,72 +3088,18 @@ NOTE: The SOAP service provider should document the
available
operations and their parameters for the service. You can also
use the `soap-inspect' function to browse the available
operations in a WSDL document."
- (let ((port (catch 'found
- (dolist (p (soap-wsdl-ports wsdl))
- (when (equal service (soap-element-name p))
- (throw 'found p))))))
- (unless port
- (error "Unknown SOAP service: %s" service))
-
- (let* ((binding (soap-port-binding port))
- (operation (gethash operation-name
- (soap-binding-operations binding))))
- (unless operation
- (error "No operation %s for SOAP service %s" operation-name service))
-
- (let ((url-request-method "POST")
- (url-package-name "soap-client.el")
- (url-package-version "1.0")
- (url-http-version "1.0")
- (url-request-data
- ;; url-request-data expects a unibyte string already encoded...
- (encode-coding-string
- (soap-create-envelope operation parameters wsdl)
- 'utf-8))
- (url-mime-charset-string "utf-8;q=1, iso-8859-1;q=0.5")
- (url-request-coding-system 'utf-8)
- (url-http-attempt-keepalives t)
- (url-request-extra-headers (list
- (cons "SOAPAction"
- (soap-bound-operation-soap-action
- operation))
- (cons "Content-Type"
- "text/xml; charset=utf-8"))))
- (let ((buffer (url-retrieve-synchronously
- (soap-port-service-url port))))
- (condition-case err
- (with-current-buffer buffer
- (declare (special url-http-response-status))
- (if (null url-http-response-status)
- (error "No HTTP response from server"))
- (if (and soap-debug (> url-http-response-status 299))
- ;; This is a warning because some SOAP errors come
- ;; back with a HTTP response 500 (internal server
- ;; error)
- (warn "Error in SOAP response: HTTP code %s"
- url-http-response-status))
- (let ((mime-part (mm-dissect-buffer t t)))
- (unless mime-part
- (error "Failed to decode response from server"))
- (unless (equal (car (mm-handle-type mime-part)) "text/xml")
- (error "Server response is not an XML document"))
- (with-temp-buffer
- (mm-insert-part mime-part)
- (let ((response (car (xml-parse-region
- (point-min) (point-max)))))
- (prog1
- (soap-parse-envelope response operation wsdl)
- (kill-buffer buffer)
- (mm-destroy-part mime-part))))))
- (soap-error
- ;; Propagate soap-errors -- they are error replies of the
- ;; SOAP protocol and don't indicate a communication
- ;; problem or a bug in this code.
- (signal (car err) (cdr err)))
- (error
- (when soap-debug
- (pop-to-buffer buffer))
- (error (error-message-string err)))))))))
+ (apply #'soap-invoke-internal nil nil wsdl service operation-name
parameters))
+
+(defun soap-invoke-async (callback cbargs wsdl service operation-name
+ &rest parameters)
+ "Like `soap-invoke', but call CALLBACK asynchronously with response.
+CALLBACK is called as (apply CALLBACK RESPONSE CBARGS), where
+RESPONSE is the SOAP invocation result. WSDL, SERVICE,
+OPERATION-NAME and PARAMETERS are as described in `soap-invoke'."
+ (unless callback
+ (error "Callback argument is nil"))
+ (apply #'soap-invoke-internal callback cbargs wsdl service operation-name
+ parameters))
(provide 'soap-client)
diff --git a/lisp/net/soap-inspect.el b/lisp/net/soap-inspect.el
index 2f9cdcb..f6c7da6 100644
--- a/lisp/net/soap-inspect.el
+++ b/lisp/net/soap-inspect.el
@@ -1,12 +1,13 @@
-;;;; soap-inspect.el -- Interactive inspector for soap WSDL structures
+;;;; soap-inspect.el -- Interactive WSDL inspector -*- lexical-binding: t
-*-
;; Copyright (C) 2010-2015 Free Software Foundation, Inc.
;; Author: Alexandru Harsanyi <address@hidden>
;; Created: October 2010
+;; Version: 3.0.1
;; Keywords: soap, web-services, comm, hypermedia
;; Package: soap-client
-;; Homepage: http://code.google.com/p/emacs-soap-client
+;; Homepage: https://github.com/alex-hhh/emacs-soap-client
;; This file is part of GNU Emacs.
@@ -55,86 +56,153 @@ will be called."
(funcall sample-value type)
(error "Cannot provide sample value for type %s" (aref type 0)))))
-(defun soap-sample-value-for-basic-type (type)
- "Provide a sample value for TYPE which is a basic type.
-This is a specific function which should not be called directly,
-use `soap-sample-value' instead."
- (case (soap-basic-type-kind type)
- (string "a string value")
- (boolean t) ; could be nil as well
- ((long int) (random 4200))
- ;; TODO: we need better sample values for more types.
- (t (format "%s" (soap-basic-type-kind type)))))
-
-(defun soap-sample-value-for-simple-type (type)
- "Provide a sample value for TYPE which is a simple type.
-This is a specific function which should not be called directly,
-use `soap-sample-value' instead."
- (let ((enumeration (soap-simple-type-enumeration type)))
- (if (> (length enumeration) 1)
- (elt enumeration (random (length enumeration)))
- (soap-sample-value-for-basic-type type))))
-
-(defun soap-sample-value-for-seqence-type (type)
- "Provide a sample value for TYPE which is a sequence type.
-Values for sequence types are ALISTS of (slot-name . VALUE) for
-each sequence element.
-
-This is a specific function which should not be called directly,
-use `soap-sample-value' instead."
- (let ((sample-value nil))
- (dolist (element (soap-sequence-type-elements type))
- (push (cons (soap-sequence-element-name element)
- (soap-sample-value (soap-sequence-element-type element)))
- sample-value))
- (when (soap-sequence-type-parent type)
- (setq sample-value
- (append (soap-sample-value (soap-sequence-type-parent type))
- sample-value)))
- sample-value))
-
-(defun soap-sample-value-for-array-type (type)
- "Provide a sample value for TYPE which is an array type.
-Values for array types are LISP vectors of values which are
-array's element type.
-
-This is a specific function which should not be called directly,
-use `soap-sample-value' instead."
- (let* ((element-type (soap-array-type-element-type type))
- (sample1 (soap-sample-value element-type))
- (sample2 (soap-sample-value element-type)))
- ;; Our sample value is a vector of two elements, but any number of
- ;; elements are permissible
- (vector sample1 sample2 '&etc)))
+(defun soap-sample-value-for-xs-basic-type (type)
+ "Provide a sample value for TYPE, an xs-basic-type.
+This is a specialization of `soap-sample-value' for xs-basic-type
+objects."
+ (case (soap-xs-basic-type-kind type)
+ (string "a string")
+ (anyURI "an URI")
+ (QName "a QName")
+ (dateTime "a time-value-p or string")
+ (boolean "t or nil")
+ ((long int integer byte unsignedInt) 42)
+ ((float double) 3.14)
+ (base64Binary "a string")
+ (t (format "%s" (soap-xs-basic-type-kind type)))))
+
+(defun soap-sample-value-for-xs-element (element)
+ "Provide a sample value for ELEMENT, a WSDL element.
+This is a specialization of `soap-sample-value' for xs-element
+objects."
+ (if (soap-xs-element-name element)
+ (cons (intern (soap-xs-element-name element))
+ (soap-sample-value (soap-xs-element-type element)))
+ (soap-sample-value (soap-xs-element-type element))))
+
+(defun soap-sample-value-for-xs-attribute (attribute)
+ "Provide a sample value for ATTRIBUTE, a WSDL attribute.
+This is a specialization of `soap-sample-value' for
+soap-xs-attribute objects."
+ (if (soap-xs-attribute-name attribute)
+ (cons (intern (soap-xs-attribute-name attribute))
+ (soap-sample-value (soap-xs-attribute-type attribute)))
+ (soap-sample-value (soap-xs-attribute-type attribute))))
+
+(defun soap-sample-value-for-xs-attribute-group (attribute-group)
+ "Provide a sample value for ATTRIBUTE-GROUP, a WSDL attribute group.
+This is a specialization of `soap-sample-value' for
+soap-xs-attribute objects."
+ (let ((sample-values nil))
+ (dolist (attribute (soap-xs-attribute-group-attributes attribute-group))
+ (if (soap-xs-attribute-name attribute)
+ (setq sample-values
+ (append sample-values
+ (cons (intern (soap-xs-attribute-name attribute))
+ (soap-sample-value (soap-xs-attribute-type
+ attribute)))))
+ (setq sample-values
+ (append sample-values
+ (soap-sample-value
+ (soap-xs-attribute-type attribute))))))))
+
+(defun soap-sample-value-for-xs-simple-type (type)
+ "Provide a sample value for TYPE, a `soap-xs-simple-type'.
+This is a specialization of `soap-sample-value' for
+`soap-xs-simple-type' objects."
+ (append
+ (mapcar 'soap-sample-value-for-xs-attribute
+ (soap-xs-type-attributes type))
+ (cond
+ ((soap-xs-simple-type-enumeration type)
+ (let ((enumeration (soap-xs-simple-type-enumeration type)))
+ (nth (random (length enumeration)) enumeration)))
+ ((soap-xs-simple-type-pattern type)
+ (format "a string matching %s" (soap-xs-simple-type-pattern type)))
+ ((soap-xs-simple-type-length-range type)
+ (destructuring-bind (low . high) (soap-xs-simple-type-length-range type)
+ (cond
+ ((and low high)
+ (format "a string between %d and %d chars long" low high))
+ (low (format "a string at least %d chars long" low))
+ (high (format "a string at most %d chars long" high))
+ (t (format "a string OOPS")))))
+ ((soap-xs-simple-type-integer-range type)
+ (destructuring-bind (min . max) (soap-xs-simple-type-integer-range type)
+ (cond
+ ((and min max) (+ min (random (- max min))))
+ (min (+ min (random 10)))
+ (max (random max))
+ (t (random 100)))))
+ ((consp (soap-xs-simple-type-base type)) ; an union of values
+ (let ((base (soap-xs-simple-type-base type)))
+ (soap-sample-value (nth (random (length base)) base))))
+ ((soap-xs-basic-type-p (soap-xs-simple-type-base type))
+ (soap-sample-value (soap-xs-simple-type-base type))))))
+
+(defun soap-sample-value-for-xs-complex-type (type)
+ "Provide a sample value for TYPE, a `soap-xs-complex-type'.
+This is a specialization of `soap-sample-value' for
+`soap-xs-complex-type' objects."
+ (append
+ (mapcar 'soap-sample-value-for-xs-attribute
+ (soap-xs-type-attributes type))
+ (case (soap-xs-complex-type-indicator type)
+ (array
+ (let* ((element-type (soap-xs-complex-type-base type))
+ (sample1 (soap-sample-value element-type))
+ (sample2 (soap-sample-value element-type)))
+ ;; Our sample value is a vector of two elements, but any number of
+ ;; elements are permissible
+ (vector sample1 sample2 '&etc)))
+ ((sequence choice all)
+ (let ((base (soap-xs-complex-type-base type)))
+ (let ((value (append (and base (soap-sample-value base))
+ (mapcar #'soap-sample-value
+ (soap-xs-complex-type-elements type)))))
+ (if (eq (soap-xs-complex-type-indicator type) 'choice)
+ (cons '***choice-of*** value)
+ value)))))))
(defun soap-sample-value-for-message (message)
"Provide a sample value for a WSDL MESSAGE.
-This is a specific function which should not be called directly,
-use `soap-sample-value' instead."
+This is a specialization of `soap-sample-value' for
+`soap-message' objects."
;; NOTE: parameter order is not considered.
(let (sample-value)
(dolist (part (soap-message-parts message))
- (push (cons (car part)
- (soap-sample-value (cdr part)))
- sample-value))
+ (push (soap-sample-value (cdr part)) sample-value))
(nreverse sample-value)))
(progn
;; Install soap-sample-value methods for our types
- (put (aref (make-soap-basic-type) 0) 'soap-sample-value
- 'soap-sample-value-for-basic-type)
+ (put (aref (make-soap-xs-basic-type) 0)
+ 'soap-sample-value
+ 'soap-sample-value-for-xs-basic-type)
- (put (aref (make-soap-simple-type) 0) 'soap-sample-value
- 'soap-sample-value-for-simple-type)
+ (put (aref (make-soap-xs-element) 0)
+ 'soap-sample-value
+ 'soap-sample-value-for-xs-element)
- (put (aref (make-soap-sequence-type) 0) 'soap-sample-value
- 'soap-sample-value-for-seqence-type)
+ (put (aref (make-soap-xs-attribute) 0)
+ 'soap-sample-value
+ 'soap-sample-value-for-xs-attribute)
- (put (aref (make-soap-array-type) 0) 'soap-sample-value
- 'soap-sample-value-for-array-type)
+ (put (aref (make-soap-xs-attribute) 0)
+ 'soap-sample-value
+ 'soap-sample-value-for-xs-attribute-group)
- (put (aref (make-soap-message) 0) 'soap-sample-value
- 'soap-sample-value-for-message) )
+ (put (aref (make-soap-xs-simple-type) 0)
+ 'soap-sample-value
+ 'soap-sample-value-for-xs-simple-type)
+
+ (put (aref (make-soap-xs-complex-type) 0)
+ 'soap-sample-value
+ 'soap-sample-value-for-xs-complex-type)
+
+ (put (aref (make-soap-message) 0)
+ 'soap-sample-value
+ 'soap-sample-value-for-message))
@@ -184,7 +252,7 @@ entire WSDL can be inspected."
(define-button-type 'soap-client-describe-link
- 'face 'italic
+ 'face 'link
'help-echo "mouse-2, RET: describe item"
'follow-link t
'action (lambda (button)
@@ -193,10 +261,10 @@ entire WSDL can be inspected."
'skip t)
(define-button-type 'soap-client-describe-back-link
- 'face 'italic
+ 'face 'link
'help-echo "mouse-2, RET: browse the previous item"
'follow-link t
- 'action (lambda (button)
+ 'action (lambda (_button)
(let ((item (pop soap-inspect-previous-items)))
(when item
(setq soap-inspect-current-item nil)
@@ -210,52 +278,142 @@ entire WSDL can be inspected."
'type 'soap-client-describe-link
'item element))
-(defun soap-inspect-basic-type (basic-type)
- "Insert information about BASIC-TYPE into the current buffer."
- (insert "Basic type: " (soap-element-fq-name basic-type))
- (insert "\nSample value\n")
- (pp (soap-sample-value basic-type) (current-buffer)))
-
-(defun soap-inspect-simple-type (simple-type)
- "Insert information about SIMPLE-TYPE into the current buffer"
- (insert "Simple type: " (soap-element-fq-name simple-type) "\n")
- (insert "Base: " (symbol-name (soap-basic-type-kind simple-type)) "\n")
- (let ((enumeration (soap-simple-type-enumeration simple-type)))
- (when (> (length enumeration) 1)
- (insert "Valid values: ")
- (dolist (e enumeration)
- (insert "\"" e "\" ")))))
-
-(defun soap-inspect-sequence-type (sequence)
- "Insert information about SEQUENCE into the current buffer."
- (insert "Sequence type: " (soap-element-fq-name sequence) "\n")
- (when (soap-sequence-type-parent sequence)
- (insert "Parent: ")
- (soap-insert-describe-button
- (soap-sequence-type-parent sequence))
- (insert "\n"))
- (insert "Elements: \n")
- (dolist (element (soap-sequence-type-elements sequence))
- (insert "\t" (symbol-name (soap-sequence-element-name element))
- "\t")
- (soap-insert-describe-button
- (soap-sequence-element-type element))
- (when (soap-sequence-element-multiple? element)
- (insert " multiple"))
- (when (soap-sequence-element-nillable? element)
- (insert " optional"))
- (insert "\n"))
- (insert "Sample value:\n")
- (pp (soap-sample-value sequence) (current-buffer)))
-
-(defun soap-inspect-array-type (array)
- "Insert information about the ARRAY into the current buffer."
- (insert "Array name: " (soap-element-fq-name array) "\n")
- (insert "Element type: ")
- (soap-insert-describe-button
- (soap-array-type-element-type array))
+(defun soap-inspect-xs-basic-type (type)
+ "Insert information about TYPE, a soap-xs-basic-type, in the current buffer."
+ (insert "Basic type: " (soap-element-fq-name type))
+ (insert "\nSample value:\n")
+ (pp (soap-sample-value type) (current-buffer)))
+
+(defun soap-inspect-xs-element (element)
+ "Insert information about ELEMENT, a soap-xs-element, in the current buffer."
+ (insert "Element: " (soap-element-fq-name element))
+ (insert "\nType: ")
+ (soap-insert-describe-button (soap-xs-element-type element))
+ (insert "\nAttributes:")
+ (when (soap-xs-element-optional? element)
+ (insert " optional"))
+ (when (soap-xs-element-multiple? element)
+ (insert " multiple"))
+ (insert "\nSample value:\n")
+ (pp (soap-sample-value element) (current-buffer)))
+
+(defun soap-inspect-xs-attribute (attribute)
+ "Insert information about ATTRIBUTE, a soap-xs-attribute, in
+the current buffer."
+ (insert "Attribute: " (soap-element-fq-name attribute))
+ (insert "\nType: ")
+ (soap-insert-describe-button (soap-xs-attribute-type attribute))
(insert "\nSample value:\n")
- (pp (soap-sample-value array) (current-buffer)))
+ (pp (soap-sample-value attribute) (current-buffer)))
+
+(defun soap-inspect-xs-attribute-group (attribute-group)
+ "Insert information about ATTRIBUTE-GROUP, a
+soap-xs-attribute-group, in the current buffer."
+ (insert "Attribute group: " (soap-element-fq-name attribute-group))
+ (insert "\nSample values:\n")
+ (pp (soap-sample-value attribute-group) (current-buffer)))
+
+(defun soap-inspect-xs-simple-type (type)
+ "Insert information about TYPE, a soap-xs-simple-type, in the current
buffer."
+ (insert "Simple type: " (soap-element-fq-name type))
+ (insert "\nBase: " )
+ (if (listp (soap-xs-simple-type-base type))
+ (let ((first-time t))
+ (dolist (b (soap-xs-simple-type-base type))
+ (unless first-time
+ (insert ", ")
+ (setq first-time nil))
+ (soap-insert-describe-button b)))
+ (soap-insert-describe-button (soap-xs-simple-type-base type)))
+ (insert "\nAttributes: ")
+ (dolist (attribute (soap-xs-simple-type-attributes type))
+ (let ((name (or (soap-xs-attribute-name attribute) "*inline*"))
+ (type (soap-xs-attribute-type attribute)))
+ (insert "\n\t")
+ (insert name)
+ (insert "\t")
+ (soap-insert-describe-button type)))
+ (when (soap-xs-simple-type-enumeration type)
+ (insert "\nEnumeraton values: ")
+ (dolist (e (soap-xs-simple-type-enumeration type))
+ (insert "\n\t")
+ (pp e)))
+ (when (soap-xs-simple-type-pattern type)
+ (insert "\nPattern: " (soap-xs-simple-type-pattern type)))
+ (when (car (soap-xs-simple-type-length-range type))
+ (insert "\nMin length: "
+ (number-to-string (car (soap-xs-simple-type-length-range type)))))
+ (when (cdr (soap-xs-simple-type-length-range type))
+ (insert "\nMin length: "
+ (number-to-string (cdr (soap-xs-simple-type-length-range type)))))
+ (when (car (soap-xs-simple-type-integer-range type))
+ (insert "\nMin value: "
+ (number-to-string (car (soap-xs-simple-type-integer-range type)))))
+ (when (cdr (soap-xs-simple-type-integer-range type))
+ (insert "\nMin value: "
+ (number-to-string (cdr (soap-xs-simple-type-integer-range type)))))
+ (insert "\nSample value:\n")
+ (pp (soap-sample-value type) (current-buffer)))
+
+(defun soap-inspect-xs-complex-type (type)
+ "Insert information about TYPE in the current buffer.
+TYPE is a `soap-xs-complex-type'"
+ (insert "Complex type: " (soap-element-fq-name type))
+ (insert "\nKind: ")
+ (case (soap-xs-complex-type-indicator type)
+ ((sequence all)
+ (insert "a sequence ")
+ (when (soap-xs-complex-type-base type)
+ (insert "extending ")
+ (soap-insert-describe-button (soap-xs-complex-type-base type)))
+ (insert "\nAttributes: ")
+ (dolist (attribute (soap-xs-complex-type-attributes type))
+ (let ((name (or (soap-xs-attribute-name attribute) "*inline*"))
+ (type (soap-xs-attribute-type attribute)))
+ (insert "\n\t")
+ (insert name)
+ (insert "\t")
+ (soap-insert-describe-button type)))
+ (insert "\nElements: ")
+ (let ((name-width 0)
+ (type-width 0))
+ (dolist (element (soap-xs-complex-type-elements type))
+ (let ((name (or (soap-xs-element-name element) "*inline*"))
+ (type (soap-xs-element-type element)))
+ (setq name-width (max name-width (length name)))
+ (setq type-width
+ (max type-width (length (soap-element-fq-name type))))))
+ (setq name-width (+ name-width 2))
+ (setq type-width (+ type-width 2))
+ (dolist (element (soap-xs-complex-type-elements type))
+ (let ((name (or (soap-xs-element-name element) "*inline*"))
+ (type (soap-xs-element-type element)))
+ (insert "\n\t")
+ (insert name)
+ (insert (make-string (- name-width (length name)) ?\ ))
+ (soap-insert-describe-button type)
+ (insert
+ (make-string
+ (- type-width (length (soap-element-fq-name type))) ?\ ))
+ (when (soap-xs-element-multiple? element)
+ (insert " multiple"))
+ (when (soap-xs-element-optional? element)
+ (insert " optional"))))))
+ (choice
+ (insert "a choice ")
+ (when (soap-xs-complex-type-base type)
+ (insert "extending ")
+ (soap-insert-describe-button (soap-xs-complex-type-base type)))
+ (insert "\nElements: ")
+ (dolist (element (soap-xs-complex-type-elements type))
+ (insert "\n\t")
+ (soap-insert-describe-button element)))
+ (array
+ (insert "an array of ")
+ (soap-insert-describe-button (soap-xs-complex-type-base type))))
+ (insert "\nSample value:\n")
+ (pp (soap-sample-value type) (current-buffer)))
+
(defun soap-inspect-message (message)
"Insert information about MESSAGE into the current buffer."
@@ -281,10 +439,11 @@ entire WSDL can be inspected."
(insert "\n\nSample invocation:\n")
(let ((sample-message-value
- (soap-sample-value (cdr (soap-operation-input operation))))
- (funcall (list 'soap-invoke '*WSDL* "SomeService" (soap-element-name
operation))))
+ (soap-sample-value (cdr (soap-operation-input operation))))
+ (funcall (list 'soap-invoke '*WSDL* "SomeService"
+ (soap-element-name operation))))
(let ((sample-invocation
- (append funcall (mapcar 'cdr sample-message-value))))
+ (append funcall (mapcar 'cdr sample-message-value))))
(pp sample-invocation (current-buffer)))))
(defun soap-inspect-port-type (port-type)
@@ -350,17 +509,23 @@ entire WSDL can be inspected."
(progn
;; Install the soap-inspect methods for our types
- (put (aref (make-soap-basic-type) 0) 'soap-inspect
- 'soap-inspect-basic-type)
+ (put (aref (make-soap-xs-basic-type) 0) 'soap-inspect
+ 'soap-inspect-xs-basic-type)
+
+ (put (aref (make-soap-xs-element) 0) 'soap-inspect
+ 'soap-inspect-xs-element)
+
+ (put (aref (make-soap-xs-simple-type) 0) 'soap-inspect
+ 'soap-inspect-xs-simple-type)
- (put (aref (make-soap-simple-type) 0) 'soap-inspect
- 'soap-inspect-simple-type)
+ (put (aref (make-soap-xs-complex-type) 0) 'soap-inspect
+ 'soap-inspect-xs-complex-type)
- (put (aref (make-soap-sequence-type) 0) 'soap-inspect
- 'soap-inspect-sequence-type)
+ (put (aref (make-soap-xs-attribute) 0) 'soap-inspect
+ 'soap-inspect-xs-attribute)
- (put (aref (make-soap-array-type) 0) 'soap-inspect
- 'soap-inspect-array-type)
+ (put (aref (make-soap-xs-attribute-group) 0) 'soap-inspect
+ 'soap-inspect-xs-attribute-group)
(put (aref (make-soap-message) 0) 'soap-inspect
'soap-inspect-message)
@@ -376,7 +541,7 @@ entire WSDL can be inspected."
(put (aref (make-soap-port) 0) 'soap-inspect
'soap-inspect-port)
- (put (aref (make-soap-wsdl) 0) 'soap-inspect
+ (put (aref (soap-make-wsdl "origin") 0) 'soap-inspect
'soap-inspect-wsdl))
(provide 'soap-inspect)
diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el
index 7157ac2..c571028 100644
--- a/lisp/net/tramp-compat.el
+++ b/lisp/net/tramp-compat.el
@@ -592,6 +592,16 @@ and replace a sub-expression, e.g.
(unless (fboundp 'format-message)
(defalias 'format-message 'format))
+;; `delete-dups' does not exist in XEmacs 21.4.
+(if (fboundp 'delete-dups)
+ (defalias 'tramp-compat-delete-dups 'delete-dups)
+ (defun tramp-compat-delete-dups (list)
+ "Destructively remove `equal' duplicates from LIST.
+Store the result in LIST and return it. LIST must be a proper list.
+Of several `equal' occurrences of an element in LIST, the first
+one is kept."
+ (cl-delete-duplicates list '(:test equal :from-end) nil)))
+
(add-hook 'tramp-unload-hook
(lambda ()
(unload-feature 'tramp-loaddefs 'force)
diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el
index 5910d1f..c956795 100644
--- a/lisp/net/tramp-smb.el
+++ b/lisp/net/tramp-smb.el
@@ -649,8 +649,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are
completely ignored."
(directory &optional full match nosort)
"Like `directory-files' for Tramp files."
(let ((result (mapcar 'directory-file-name
- (file-name-all-completions "" directory)))
- res)
+ (file-name-all-completions "" directory))))
;; Discriminate with regexp.
(when match
(setq result
@@ -666,8 +665,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are
completely ignored."
;; Sort them if necessary.
(unless nosort (setq result (sort result 'string-lessp)))
;; Remove double entries.
- (dolist (elt result res)
- (add-to-list 'res elt 'append))))
+ (tramp-compat-delete-dups result)))
(defun tramp-smb-handle-expand-file-name (name &optional dir)
"Like `expand-file-name' for Tramp files."
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index 30a7269..2f811bb 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -4043,6 +4043,7 @@ Return the local name of the temporary file."
'tramp-delete-temp-file-function)))
;;; Auto saving to a special directory:
+(defvar auto-save-file-name-transforms)
(defun tramp-handle-make-auto-save-file-name ()
"Like `make-auto-save-file-name' for Tramp files.
diff --git a/lisp/obsolete/vc-arch.el b/lisp/obsolete/vc-arch.el
index bdb6975..e6540ce 100644
--- a/lisp/obsolete/vc-arch.el
+++ b/lisp/obsolete/vc-arch.el
@@ -310,6 +310,10 @@ Only the value `maybe' can be trusted :-(."
'up-to-date
'edited)))))))))
+;; dir-status-files called from vc-dir, which loads vc,
+;; which loads vc-dispatcher.
+(declare-function vc-exec-after "vc-dispatcher" (code))
+
(defun vc-arch-dir-status-files (dir _files callback)
"Run `tla inventory' for DIR and pass results to CALLBACK.
CALLBACK expects (ENTRIES &optional MORE-TO-COME); see
diff --git a/lisp/progmodes/grep.el b/lisp/progmodes/grep.el
index 452a42f..efecd21 100644
--- a/lisp/progmodes/grep.el
+++ b/lisp/progmodes/grep.el
@@ -731,21 +731,24 @@ This function is called from `compilation-filter-hook'."
;;;###autoload
(defun grep (command-args)
- "Run grep, with user-specified args, and collect output in a buffer.
-While grep runs asynchronously, you can use \\[next-error] (M-x next-error),
+ "Run Grep with user-specified COMMAND-ARGS, collect output in a buffer.
+While Grep runs asynchronously, you can use \\[next-error] (M-x next-error),
or \\<grep-mode-map>\\[compile-goto-error] in the *grep* \
-buffer, to go to the lines where grep found
-matches. To kill the grep job before it finishes, type \\[kill-compilation].
+buffer, to go to the lines where Grep found
+matches. To kill the Grep job before it finishes, type \\[kill-compilation].
+
+Noninteractively, COMMAND-ARGS should specify the Grep command-line
+arguments.
For doing a recursive `grep', see the `rgrep' command. For running
-`grep' in a specific directory, see `lgrep'.
+Grep in a specific directory, see `lgrep'.
This command uses a special history list for its COMMAND-ARGS, so you
can easily repeat a grep command.
-A prefix argument says to default the argument based upon the current
-tag the cursor is over, substituting it into the last grep command
-in the grep command history (or into `grep-command' if that history
+A prefix argument says to default the COMMAND-ARGS based on the current
+tag the cursor is over, substituting it into the last Grep command
+in the Grep command history (or into `grep-command' if that history
list is empty)."
(interactive
(progn
diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el
index fbb4a90..baed27b 100644
--- a/lisp/progmodes/sh-script.el
+++ b/lisp/progmodes/sh-script.el
@@ -1920,10 +1920,11 @@ Does not preserve point."
;; Pretend the here-document is a "newline representing a
;; semi-colon", since the here-doc otherwise covers the newline(s).
";")
- (let ((semi (sh-smie--newline-semi-p)))
- (forward-line 1)
- (if (or semi (eobp)) ";"
- (sh-smie-sh-forward-token))))
+ (unless (eobp)
+ (let ((semi (sh-smie--newline-semi-p)))
+ (forward-line 1)
+ (if (or semi (eobp)) ";"
+ (sh-smie-sh-forward-token)))))
(forward-comment (point-max))
(cond
((looking-at "\\\\\n") (forward-line 1) (sh-smie-sh-forward-token))
diff --git a/lisp/simple.el b/lisp/simple.el
index 8acb683..f6c580f 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -458,18 +458,27 @@ A non-nil INTERACTIVE argument means to run the
`post-self-insert-hook'."
(put-text-property from (point) 'rear-nonsticky
(cons 'hard sticky)))))
-(defun open-line (n)
+(declare-function electric-indent-just-newline "electric")
+(defun open-line (n &optional interactive)
"Insert a newline and leave point before it.
-If there is a fill prefix and/or a `left-margin', insert them
-on the new line if the line would have been blank.
-With arg N, insert N newlines."
- (interactive "*p")
+If `electric-indent-mode' is enabled, indent the new line if it's
+not empty.
+If there is a fill prefix and/or a `left-margin', insert them on
+the new line. If the old line would have been blank, insert them
+on the old line as well.
+
+With arg N, insert N newlines.
+A non-nil INTERACTIVE argument means to run the `post-self-insert-hook'."
+ (interactive "*p\np")
(let* ((do-fill-prefix (and fill-prefix (bolp)))
(do-left-margin (and (bolp) (> (current-left-margin) 0)))
(loc (point-marker))
- ;; Don't expand an abbrev before point.
+ ;; Don't expand an abbrev before point.
(abbrev-mode nil))
- (newline n)
+ (if (and interactive
+ (looking-at-p "[[:space:]]*$"))
+ (electric-indent-just-newline n)
+ (newline n interactive))
(goto-char loc)
(while (> n 0)
(cond ((bolp)
@@ -478,6 +487,7 @@ With arg N, insert N newlines."
(forward-line 1)
(setq n (1- n)))
(goto-char loc)
+ ;; Necessary in case a margin or prefix was inserted.
(end-of-line)))
(defun split-line (&optional arg)
@@ -599,7 +609,8 @@ buffer if the variable `delete-trailing-lines' is non-nil."
(start (or start (point-min))))
(goto-char start)
(while (re-search-forward "\\s-$" end-marker t)
- (skip-syntax-backward "-" (line-beginning-position))
+ (save-match-data
+ (skip-syntax-backward "-" (line-beginning-position)))
;; Don't delete formfeeds, even if they are considered whitespace.
(if (looking-at-p ".*\f")
(goto-char (match-end 0)))
diff --git a/lisp/textmodes/tex-mode.el b/lisp/textmodes/tex-mode.el
index 45afafc..0b13759 100644
--- a/lisp/textmodes/tex-mode.el
+++ b/lisp/textmodes/tex-mode.el
@@ -3410,18 +3410,24 @@ There might be text before point."
"A `prettify-symbols-alist' usable for (La)TeX modes.")
(defun tex--prettify-symbols-compose-p (_start end _match)
- (let* ((after-char (char-after end))
- (after-syntax (char-syntax after-char)))
- (not (or
- ;; Don't compose address@hidden
- (eq after-char ?@)
- ;; The \alpha in \alpha2 or \alpha-\beta may be composed but
- ;; of course \alphax may not.
- (and (eq after-syntax ?w)
- (not (memq after-char
- '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9 ?+ ?- ?' ?\"))))
- ;; Don't compose inside verbatim blocks.
- (eq 2 (nth 7 (syntax-ppss)))))))
+ (or
+ ;; If the matched symbol doesn't end in a word character, then we
+ ;; simply allow composition. The symbol is probably something like
+ ;; \|, \(, etc.
+ (not (eq ?w (char-syntax (char-before end))))
+ ;; Else we look at what follows the match in order to decide.
+ (let* ((after-char (char-after end))
+ (after-syntax (char-syntax after-char)))
+ (not (or
+ ;; Don't compose address@hidden
+ (eq after-char ?@)
+ ;; The \alpha in \alpha2 or \alpha-\beta may be composed but
+ ;; of course \alphax may not.
+ (and (eq after-syntax ?w)
+ (not (memq after-char
+ '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9 ?+ ?- ?' ?\"))))
+ ;; Don't compose inside verbatim blocks.
+ (eq 2 (nth 7 (syntax-ppss))))))))
(run-hooks 'tex-mode-load-hook)
diff --git a/lisp/vc/pcvs.el b/lisp/vc/pcvs.el
index f6a9e08..3fdee10 100644
--- a/lisp/vc/pcvs.el
+++ b/lisp/vc/pcvs.el
@@ -2312,7 +2312,7 @@ this file, or a list of arguments to send to the program."
(revert-buffer 'ignore-auto 'dont-ask 'preserve-modes)
;; `preserve-modes' avoids changing the (minor) modes. But we
;; do want to reset the mode for VC, so we do it explicitly.
- (vc-find-file-hook)
+ (vc-refresh-state)
(when (eq (cvs-fileinfo->type fileinfo) 'CONFLICT)
(smerge-start-session))))))))
diff --git a/lisp/vc/vc-bzr.el b/lisp/vc/vc-bzr.el
index 40f2516..9b2711d 100644
--- a/lisp/vc/vc-bzr.el
+++ b/lisp/vc/vc-bzr.el
@@ -331,6 +331,7 @@ in the repository root directory of FILE."
"Value of `compilation-error-regexp-alist' in *vc-bzr* buffers.")
;; To be called via vc-pull from vc.el, which requires vc-dispatcher.
+(declare-function vc-exec-after "vc-dispatcher" (code))
(declare-function vc-set-async-update "vc-dispatcher" (process-buffer))
(declare-function vc-compilation-mode "vc-dispatcher" (backend))
diff --git a/lisp/vc/vc-cvs.el b/lisp/vc/vc-cvs.el
index c0a199d..5f5807f 100644
--- a/lisp/vc/vc-cvs.el
+++ b/lisp/vc/vc-cvs.el
@@ -543,6 +543,8 @@ Will fail unless you have administrative privileges on the
repo."
;;;
(declare-function vc-rcs-print-log-cleanup "vc-rcs" ())
+;; Follows vc-cvs-command, which uses vc-do-command from vc-dispatcher.
+(declare-function vc-exec-after "vc-dispatcher" (code))
(defun vc-cvs-print-log (files buffer &optional _shortlog _start-revision
limit)
"Print commit log associated with FILES into specified BUFFER.
diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el
index 0e33896..27898a9 100644
--- a/lisp/vc/vc-git.el
+++ b/lisp/vc/vc-git.el
@@ -461,6 +461,8 @@ or an empty string if none."
;; Follows vc-git-command (or vc-do-async-command), which uses vc-do-command
;; from vc-dispatcher.
+(declare-function vc-exec-after "vc-dispatcher" (code))
+;; Follows vc-exec-after.
(declare-function vc-set-async-update "vc-dispatcher" (process-buffer))
(defun vc-git-dir-status-goto-stage (stage files update-function)
diff --git a/lisp/vc/vc-hg.el b/lisp/vc/vc-hg.el
index c4d6092..f9957c1 100644
--- a/lisp/vc/vc-hg.el
+++ b/lisp/vc/vc-hg.el
@@ -259,6 +259,14 @@ highlighting the Log View buffer."
(defvar vc-hg-log-graph nil
"If non-nil, use `--graph' in the short log output.")
+(defvar vc-hg-log-format (concat "changeset: {rev}:{node|short}\n"
+ "{tags % 'tag: {tag}\n'}"
+ "{if(parents, 'parents: {parents}\n')}"
+ "user: {author}\n"
+ "Date: {date|date}\n"
+ "summary: {desc|tabindent}\n\n")
+ "Mercurial log template for `vc-hg-print-log' long format.")
+
(defun vc-hg-print-log (files buffer &optional shortlog start-revision limit)
"Print commit log associated with FILES into specified BUFFER.
If SHORTLOG is non-nil, use a short format based on `vc-hg-root-log-format'.
@@ -276,9 +284,11 @@ If LIMIT is non-nil, show no more than this many entries."
(nconc
(when start-revision (list (format "-r%s:0" start-revision)))
(when limit (list "-l" (format "%s" limit)))
- (when shortlog `(,@(if vc-hg-log-graph '("--graph"))
- "--template"
- ,(car vc-hg-root-log-format)))
+ (if shortlog
+ `(,@(if vc-hg-log-graph '("--graph"))
+ "--template"
+ ,(car vc-hg-root-log-format))
+ `("--template" ,vc-hg-log-format))
vc-hg-log-switches)))))
(defvar log-view-message-re)
@@ -295,6 +305,7 @@ If LIMIT is non-nil, show no more than this many entries."
(if (eq vc-log-view-type 'short)
(cadr vc-hg-root-log-format)
"^changeset:[ \t]*\\([0-9]+\\):\\(.+\\)"))
+ (set (make-local-variable 'tab-width) 2)
;; Allow expanding short log entries
(when (eq vc-log-view-type 'short)
(setq truncate-lines t)
@@ -345,7 +356,7 @@ If LIMIT is non-nil, show no more than this many entries."
(defun vc-hg-expanded-log-entry (revision)
(with-temp-buffer
- (vc-hg-command t nil nil "log" "-r" revision)
+ (vc-hg-command t nil nil "log" "-r" revision "--template" vc-hg-log-format)
(goto-char (point-min))
(unless (eobp)
;; Indent the expanded log entry.
@@ -620,6 +631,8 @@ REV is the revision to check out into WORKFILE."
;; Follows vc-hg-command (or vc-do-async-command), which uses vc-do-command
;; from vc-dispatcher.
+(declare-function vc-exec-after "vc-dispatcher" (code))
+;; Follows vc-exec-after.
(declare-function vc-set-async-update "vc-dispatcher" (process-buffer))
(defun vc-hg-dir-status-files (dir files update-function)
diff --git a/lisp/vc/vc-mtn.el b/lisp/vc/vc-mtn.el
index 3197d60..b56a08f 100644
--- a/lisp/vc/vc-mtn.el
+++ b/lisp/vc/vc-mtn.el
@@ -138,6 +138,10 @@ switches."
((match-end 2) (push (list (match-string 3) 'added) result))))
(funcall update-function result)))
+;; dir-status-files called from vc-dir, which loads vc,
+;; which loads vc-dispatcher.
+(declare-function vc-exec-after "vc-dispatcher" (code))
+
(defun vc-mtn-dir-status-files (dir _files update-function)
(vc-mtn-command (current-buffer) 'async dir "status")
(vc-run-delayed
diff --git a/lisp/vc/vc-svn.el b/lisp/vc/vc-svn.el
index 2ec65a1..4ef63a2 100644
--- a/lisp/vc/vc-svn.el
+++ b/lisp/vc/vc-svn.el
@@ -208,6 +208,10 @@ switches."
(setq result (cons (list filename state) result)))))
(funcall callback result)))
+;; dir-status-files called from vc-dir, which loads vc,
+;; which loads vc-dispatcher.
+(declare-function vc-exec-after "vc-dispatcher" (code))
+
(autoload 'vc-expand-dirs "vc")
(defun vc-svn-dir-status-files (_dir files callback)
diff --git a/nextstep/Cocoa/Emacs.base/Contents/Resources/Emacs.icns
b/nextstep/Cocoa/Emacs.base/Contents/Resources/Emacs.icns
index 14785d5..7153403 100644
Binary files a/nextstep/Cocoa/Emacs.base/Contents/Resources/Emacs.icns and
b/nextstep/Cocoa/Emacs.base/Contents/Resources/Emacs.icns differ
diff --git a/nt/addpm.c b/nt/addpm.c
index cd91a3e..8dfb4bd 100644
--- a/nt/addpm.c
+++ b/nt/addpm.c
@@ -62,15 +62,12 @@ DdeCallback (UINT uType, UINT uFmt, HCONV hconv,
}
#define DdeCommand(str) \
- DdeClientTransaction (str, strlen (str)+1, conversation, (HSZ)NULL, \
+ DdeClientTransaction ((LPBYTE)str, strlen (str)+1, conversation,
(HSZ)NULL, \
CF_TEXT, XTYP_EXECUTE, 30000, NULL)
#define REG_ROOT "SOFTWARE\\GNU\\Emacs"
-#define REG_GTK "SOFTWARE\\GTK\\2.0"
#define REG_APP_PATH \
"SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\App Paths\\emacs.exe"
-#define REG_RUNEMACS_PATH \
- "SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\App Paths\\runemacs.exe"
static struct entry
{
@@ -104,13 +101,11 @@ env_vars[] =
#endif
};
-BOOL
+void
add_registry (const char *path)
{
HKEY hrootkey = NULL;
int i;
- BOOL ok = TRUE;
- DWORD size;
/* Record the location of Emacs to the App Paths key if we have
sufficient permissions to do so. This helps Windows find emacs quickly
@@ -121,60 +116,18 @@ add_registry (const char *path)
affect the general operation of other installations of Emacs, and we
are blindly overwriting the Start Menu entries already.
*/
- if (RegCreateKeyEx (HKEY_LOCAL_MACHINE, REG_APP_PATH, 0, "",
+ if (RegCreateKeyEx (HKEY_LOCAL_MACHINE, REG_APP_PATH, 0, NULL,
REG_OPTION_NON_VOLATILE, KEY_WRITE, NULL,
&hrootkey, NULL) == ERROR_SUCCESS)
{
int len;
char *emacs_path;
- HKEY gtk_key = NULL;
len = strlen (path) + 15; /* \bin\emacs.exe + terminator. */
emacs_path = (char *) alloca (len);
sprintf (emacs_path, "%s\\bin\\emacs.exe", path);
RegSetValueEx (hrootkey, NULL, 0, REG_EXPAND_SZ, emacs_path, len);
-
- /* Look for a GTK installation. If found, add it to the library search
- path for Emacs so that the image libraries it provides are available
- to Emacs regardless of whether it is in the path or not. */
- if (RegOpenKeyEx (HKEY_LOCAL_MACHINE, REG_GTK, REG_OPTION_NON_VOLATILE,
- KEY_READ, >k_key) == ERROR_SUCCESS)
- {
- if (RegQueryValueEx (gtk_key, "DllPath", NULL, NULL,
- NULL, &size) == ERROR_SUCCESS)
- {
- char *gtk_path = (char *) alloca (size);
- if (RegQueryValueEx (gtk_key, "DllPath", NULL, NULL,
- gtk_path, &size) == ERROR_SUCCESS)
- {
- /* Make sure the emacs bin directory continues to be searched
- first by including it as well. */
- char *dll_paths;
- HKEY runemacs_key = NULL;
- len = strlen (path) + 5 + size;
- dll_paths = (char *) alloca (size + strlen (path) + 1);
- sprintf (dll_paths, "%s\\bin;%s", path, gtk_path);
- RegSetValueEx (hrootkey, "Path", 0, REG_EXPAND_SZ,
- dll_paths, len);
-
- /* Set the same path for runemacs.exe, as the Explorer shell
- looks this up, so the above does not take effect when
- emacs.exe is spawned from runemacs.exe. */
- if (RegCreateKeyEx (HKEY_LOCAL_MACHINE, REG_RUNEMACS_PATH,
- 0, "", REG_OPTION_NON_VOLATILE,
- KEY_WRITE, NULL, &runemacs_key, NULL)
- == ERROR_SUCCESS)
- {
- RegSetValueEx (runemacs_key, "Path", 0, REG_EXPAND_SZ,
- dll_paths, len);
-
- RegCloseKey (runemacs_key);
- }
- }
- }
- RegCloseKey (gtk_key);
- }
RegCloseKey (hrootkey);
}
@@ -186,29 +139,24 @@ add_registry (const char *path)
/* Check both the current user and the local machine to see if we
have any resources. */
- if (RegOpenKeyEx (HKEY_LOCAL_MACHINE, REG_ROOT,
- REG_OPTION_NON_VOLATILE,
- KEY_WRITE, &hrootkey) != ERROR_SUCCESS
- && RegOpenKeyEx (HKEY_CURRENT_USER, REG_ROOT,
- REG_OPTION_NON_VOLATILE,
- KEY_WRITE, &hrootkey) != ERROR_SUCCESS)
- {
- return FALSE;
- }
+ if (RegOpenKeyEx (HKEY_LOCAL_MACHINE, REG_ROOT, 0,
+ KEY_WRITE | KEY_QUERY_VALUE, &hrootkey) != ERROR_SUCCESS
+ && RegOpenKeyEx (HKEY_CURRENT_USER, REG_ROOT, 0,
+ KEY_WRITE | KEY_QUERY_VALUE, &hrootkey) != ERROR_SUCCESS)
+ return;
for (i = 0; i < (sizeof (env_vars) / sizeof (env_vars[0])); i++)
{
const char * value = env_vars[i].value ? env_vars[i].value : path;
- if (RegSetValueEx (hrootkey, env_vars[i].name,
- 0, REG_EXPAND_SZ,
- value, lstrlen (value) + 1) != ERROR_SUCCESS)
- ok = FALSE;
+ /* Replace only those settings that already exist. */
+ if (RegQueryValueEx (hrootkey, env_vars[i].name, NULL,
+ NULL, NULL, NULL) == ERROR_SUCCESS)
+ RegSetValueEx (hrootkey, env_vars[i].name, 0, REG_EXPAND_SZ,
+ value, lstrlen (value) + 1);
}
RegCloseKey (hrootkey);
-
- return (ok);
}
int
diff --git a/nt/icons/emacs.ico b/nt/icons/emacs.ico
index 7c93625..b244568 100644
Binary files a/nt/icons/emacs.ico and b/nt/icons/emacs.ico differ
diff --git a/src/dispnew.c b/src/dispnew.c
index 5be757d..d965a51 100644
--- a/src/dispnew.c
+++ b/src/dispnew.c
@@ -6109,8 +6109,8 @@ init_display (void)
change. It's not clear what better we could do. The rest of
the code assumes that (width + 2) * height * sizeof (struct glyph)
does not overflow and does not exceed PTRDIFF_MAX or SIZE_MAX. */
- if (INT_ADD_RANGE_OVERFLOW (width, 2, INT_MIN, INT_MAX)
- || INT_MULTIPLY_RANGE_OVERFLOW (width + 2, height, INT_MIN, INT_MAX)
+ if (INT_ADD_OVERFLOW (width, 2)
+ || INT_MULTIPLY_OVERFLOW (width + 2, height)
|| (min (PTRDIFF_MAX, SIZE_MAX) / sizeof (struct glyph)
< (width + 2) * height))
fatal ("screen size %dx%d too big", width, height);
diff --git a/src/keyboard.c b/src/keyboard.c
index 84d7812..235f4c3 100644
--- a/src/keyboard.c
+++ b/src/keyboard.c
@@ -11393,14 +11393,22 @@ Buffer modification stores t in this variable. */);
doc: /* Normal hook run before each command is executed.
If an unhandled error happens in running this hook,
the function in which the error occurred is unconditionally removed, since
-otherwise the error might happen repeatedly and make Emacs nonfunctional. */);
+otherwise the error might happen repeatedly and make Emacs nonfunctional.
+
+See also `pre-command-hook'. */);
Vpre_command_hook = Qnil;
DEFVAR_LISP ("post-command-hook", Vpost_command_hook,
doc: /* Normal hook run after each command is executed.
If an unhandled error happens in running this hook,
the function in which the error occurred is unconditionally removed, since
-otherwise the error might happen repeatedly and make Emacs nonfunctional. */);
+otherwise the error might happen repeatedly and make Emacs nonfunctional.
+
+It is a bad idea to use this hook for expensive processing. If
+unavoidable, wrap your code in `(while-no-input (redisplay) CODE)' to
+avoid making Emacs unresponsive while the user types.
+
+See also `pre-command-hook'. */);
Vpost_command_hook = Qnil;
#if 0
diff --git a/src/lisp.h b/src/lisp.h
index a57837f..ff6e7a1 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -258,7 +258,7 @@ enum Lisp_Bits
/* The maximum value that can be stored in a EMACS_INT, assuming all
bits other than the type bits contribute to a nonnegative signed value.
- This can be used in #if, e.g., '#if USB_TAG' below expands to an
+ This can be used in #if, e.g., '#if USE_LSB_TAG' below expands to an
expression involving VAL_MAX. */
#define VAL_MAX (EMACS_INT_MAX >> (GCTYPEBITS - 1))
@@ -301,10 +301,6 @@ error !;
and/or via a function definition like this:
- LISP_MACRO_DEFUN (OP, Lisp_Object, (Lisp_Object x), (x))
-
- which macro-expands to this:
-
Lisp_Object (OP) (Lisp_Object x) { return lisp_h_OP (x); }
without worrying about the implementations diverging, since
@@ -408,17 +404,6 @@ error !;
# endif
#endif
-/* Define NAME as a lisp.h inline function that returns TYPE and has
- arguments declared as ARGDECLS and passed as ARGS. ARGDECLS and
- ARGS should be parenthesized. Implement the function by calling
- lisp_h_NAME ARGS. */
-#define LISP_MACRO_DEFUN(name, type, argdecls, args) \
- INLINE type (name) argdecls { return lisp_h_##name args; }
-
-/* like LISP_MACRO_DEFUN, except NAME returns void. */
-#define LISP_MACRO_DEFUN_VOID(name, argdecls, args) \
- INLINE void (name) argdecls { lisp_h_##name args; }
-
/* Define the fundamental Lisp data structures. */
@@ -751,8 +736,18 @@ struct Lisp_Symbol
/* Convert a Lisp_Object to the corresponding EMACS_INT and vice versa.
At the machine level, these operations are no-ops. */
-LISP_MACRO_DEFUN (XLI, EMACS_INT, (Lisp_Object o), (o))
-LISP_MACRO_DEFUN (XIL, Lisp_Object, (EMACS_INT i), (i))
+
+INLINE EMACS_INT
+(XLI) (Lisp_Object o)
+{
+ return lisp_h_XLI (o);
+}
+
+INLINE Lisp_Object
+(XIL) (EMACS_INT i)
+{
+ return lisp_h_XIL (i);
+}
/* In the size word of a vector, this bit means the vector has been marked. */
@@ -834,12 +829,41 @@ DEFINE_GDB_SYMBOL_END (VALMASK)
#if USE_LSB_TAG
-LISP_MACRO_DEFUN (make_number, Lisp_Object, (EMACS_INT n), (n))
-LISP_MACRO_DEFUN (XINT, EMACS_INT, (Lisp_Object a), (a))
-LISP_MACRO_DEFUN (XFASTINT, EMACS_INT, (Lisp_Object a), (a))
-LISP_MACRO_DEFUN (XSYMBOL, struct Lisp_Symbol *, (Lisp_Object a), (a))
-LISP_MACRO_DEFUN (XTYPE, enum Lisp_Type, (Lisp_Object a), (a))
-LISP_MACRO_DEFUN (XUNTAG, void *, (Lisp_Object a, int type), (a, type))
+INLINE Lisp_Object
+(make_number) (EMACS_INT n)
+{
+ return lisp_h_make_number (n);
+}
+
+INLINE EMACS_INT
+(XINT) (Lisp_Object a)
+{
+ return lisp_h_XINT (a);
+}
+
+INLINE EMACS_INT
+(XFASTINT) (Lisp_Object a)
+{
+ return lisp_h_XFASTINT (a);
+}
+
+INLINE struct Lisp_Symbol *
+(XSYMBOL) (Lisp_Object a)
+{
+ return lisp_h_XSYMBOL (a);
+}
+
+INLINE enum Lisp_Type
+(XTYPE) (Lisp_Object a)
+{
+ return lisp_h_XTYPE (a);
+}
+
+INLINE void *
+(XUNTAG) (Lisp_Object a, int type)
+{
+ return lisp_h_XUNTAG (a, type);
+}
#else /* ! USE_LSB_TAG */
@@ -930,7 +954,12 @@ XUINT (Lisp_Object a)
/* Return A's (Lisp-integer sized) hash. Happens to be like XUINT
right now, but XUINT should only be applied to objects we know are
integers. */
-LISP_MACRO_DEFUN (XHASH, EMACS_INT, (Lisp_Object a), (a))
+
+INLINE EMACS_INT
+(XHASH) (Lisp_Object a)
+{
+ return lisp_h_XHASH (a);
+}
/* Like make_number (N), but may be faster. N must be in nonnegative range.
*/
INLINE Lisp_Object
@@ -942,7 +971,12 @@ make_natnum (EMACS_INT n)
}
/* Return true if X and Y are the same object. */
-LISP_MACRO_DEFUN (EQ, bool, (Lisp_Object x, Lisp_Object y), (x, y))
+
+INLINE bool
+(EQ) (Lisp_Object x, Lisp_Object y)
+{
+ return lisp_h_EQ (x, y);
+}
/* Value is true if I doesn't fit into a Lisp fixnum. It is
written this way so that it also works if I is of unsigned
@@ -960,7 +994,11 @@ clip_to_bounds (ptrdiff_t lower, EMACS_INT num, ptrdiff_t
upper)
/* Extract a value or address from a Lisp_Object. */
-LISP_MACRO_DEFUN (XCONS, struct Lisp_Cons *, (Lisp_Object a), (a))
+INLINE struct Lisp_Cons *
+(XCONS) (Lisp_Object a)
+{
+ return lisp_h_XCONS (a);
+}
INLINE struct Lisp_Vector *
XVECTOR (Lisp_Object a)
@@ -1133,9 +1171,11 @@ make_pointer_integer (void *p)
/* Type checking. */
-LISP_MACRO_DEFUN_VOID (CHECK_TYPE,
- (int ok, Lisp_Object predicate, Lisp_Object x),
- (ok, predicate, x))
+INLINE void
+(CHECK_TYPE) (int ok, Lisp_Object predicate, Lisp_Object x)
+{
+ lisp_h_CHECK_TYPE (ok, predicate, x);
+}
/* See the macros in intervals.h. */
@@ -1175,8 +1215,18 @@ xcdr_addr (Lisp_Object c)
}
/* Use these from normal code. */
-LISP_MACRO_DEFUN (XCAR, Lisp_Object, (Lisp_Object c), (c))
-LISP_MACRO_DEFUN (XCDR, Lisp_Object, (Lisp_Object c), (c))
+
+INLINE Lisp_Object
+(XCAR) (Lisp_Object c)
+{
+ return lisp_h_XCAR (c);
+}
+
+INLINE Lisp_Object
+(XCDR) (Lisp_Object c)
+{
+ return lisp_h_XCDR (c);
+}
/* Use these to set the fields of a cons cell.
@@ -1713,7 +1763,11 @@ verify (offsetof (struct Lisp_Sub_Char_Table, contents)
/* Value is name of symbol. */
-LISP_MACRO_DEFUN (SYMBOL_VAL, Lisp_Object, (struct Lisp_Symbol *sym), (sym))
+INLINE Lisp_Object
+(SYMBOL_VAL) (struct Lisp_Symbol *sym)
+{
+ return lisp_h_SYMBOL_VAL (sym);
+}
INLINE struct Lisp_Symbol *
SYMBOL_ALIAS (struct Lisp_Symbol *sym)
@@ -1734,8 +1788,11 @@ SYMBOL_FWD (struct Lisp_Symbol *sym)
return sym->val.fwd;
}
-LISP_MACRO_DEFUN_VOID (SET_SYMBOL_VAL,
- (struct Lisp_Symbol *sym, Lisp_Object v), (sym, v))
+INLINE void
+(SET_SYMBOL_VAL) (struct Lisp_Symbol *sym, Lisp_Object v)
+{
+ lisp_h_SET_SYMBOL_VAL (sym, v);
+}
INLINE void
SET_SYMBOL_ALIAS (struct Lisp_Symbol *sym, struct Lisp_Symbol *v)
@@ -1782,7 +1839,11 @@ SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (Lisp_Object sym)
value cannot be changed (there is an exception for keyword symbols,
whose value can be set to the keyword symbol itself). */
-LISP_MACRO_DEFUN (SYMBOL_CONSTANT_P, int, (Lisp_Object sym), (sym))
+INLINE int
+(SYMBOL_CONSTANT_P) (Lisp_Object sym)
+{
+ return lisp_h_SYMBOL_CONSTANT_P (sym);
+}
/* Placeholder for make-docfile to process. The actual symbol
definition is done by lread.c's defsym. */
@@ -2452,7 +2513,11 @@ enum char_bits
/* Data type checking. */
-LISP_MACRO_DEFUN (NILP, bool, (Lisp_Object x), (x))
+INLINE bool
+(NILP) (Lisp_Object x)
+{
+ return lisp_h_NILP (x);
+}
INLINE bool
NUMBERP (Lisp_Object x)
@@ -2476,13 +2541,41 @@ RANGED_INTEGERP (intmax_t lo, Lisp_Object x, intmax_t
hi)
&& (TYPE_SIGNED (type) ? TYPE_MINIMUM (type) <= XINT (x) : 0 <= XINT (x)) \
&& XINT (x) <= TYPE_MAXIMUM (type))
-LISP_MACRO_DEFUN (CONSP, bool, (Lisp_Object x), (x))
-LISP_MACRO_DEFUN (FLOATP, bool, (Lisp_Object x), (x))
-LISP_MACRO_DEFUN (MISCP, bool, (Lisp_Object x), (x))
-LISP_MACRO_DEFUN (SYMBOLP, bool, (Lisp_Object x), (x))
-LISP_MACRO_DEFUN (INTEGERP, bool, (Lisp_Object x), (x))
-LISP_MACRO_DEFUN (VECTORLIKEP, bool, (Lisp_Object x), (x))
-LISP_MACRO_DEFUN (MARKERP, bool, (Lisp_Object x), (x))
+INLINE bool
+(CONSP) (Lisp_Object x)
+{
+ return lisp_h_CONSP (x);
+}
+INLINE bool
+(FLOATP) (Lisp_Object x)
+{
+ return lisp_h_FLOATP (x);
+}
+INLINE bool
+(MISCP) (Lisp_Object x)
+{
+ return lisp_h_MISCP (x);
+}
+INLINE bool
+(SYMBOLP) (Lisp_Object x)
+{
+ return lisp_h_SYMBOLP (x);
+}
+INLINE bool
+(INTEGERP) (Lisp_Object x)
+{
+ return lisp_h_INTEGERP (x);
+}
+INLINE bool
+(VECTORLIKEP) (Lisp_Object x)
+{
+ return lisp_h_VECTORLIKEP (x);
+}
+INLINE bool
+(MARKERP) (Lisp_Object x)
+{
+ return lisp_h_MARKERP (x);
+}
INLINE bool
STRINGP (Lisp_Object x)
@@ -2633,9 +2726,23 @@ CHECK_LIST (Lisp_Object x)
CHECK_TYPE (CONSP (x) || NILP (x), Qlistp, x);
}
-LISP_MACRO_DEFUN_VOID (CHECK_LIST_CONS, (Lisp_Object x, Lisp_Object y), (x, y))
-LISP_MACRO_DEFUN_VOID (CHECK_SYMBOL, (Lisp_Object x), (x))
-LISP_MACRO_DEFUN_VOID (CHECK_NUMBER, (Lisp_Object x), (x))
+INLINE void
+(CHECK_LIST_CONS) (Lisp_Object x, Lisp_Object y)
+{
+ lisp_h_CHECK_LIST_CONS (x, y);
+}
+
+INLINE void
+(CHECK_SYMBOL) (Lisp_Object x)
+{
+ lisp_h_CHECK_SYMBOL (x);
+}
+
+INLINE void
+(CHECK_NUMBER) (Lisp_Object x)
+{
+ lisp_h_CHECK_NUMBER (x);
+}
INLINE void
CHECK_STRING (Lisp_Object x)
diff --git a/src/lread.c b/src/lread.c
index a98fa61..1119f3f 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -4479,8 +4479,10 @@ were read in. */);
DEFVAR_LISP ("load-path", Vload_path,
doc: /* List of directories to search for files to load.
-Each element is a string (directory name) or nil (meaning `default-directory').
-Initialized during startup as described in Info node `(elisp)Library Search'.
*/);
+Each element is a string (directory file name) or nil (meaning
+`default-directory'). Initialized during startup as described in Info
+node `(elisp)Library Search'. Use `directory-file-name' when adding items
+to this path. */);
DEFVAR_LISP ("load-suffixes", Vload_suffixes,
doc: /* List of suffixes for (compiled or source) Emacs Lisp
files.
diff --git a/src/nsfns.m b/src/nsfns.m
index 43002ca..c243444 100644
--- a/src/nsfns.m
+++ b/src/nsfns.m
@@ -49,13 +49,6 @@ GNUstep port and post-20 update by Adrian Robert
(address@hidden)
#include "macfont.h"
#endif
-#if 0
-int fns_trace_num = 1;
-#define NSTRACE(x) fprintf (stderr, "%s:%d: [%d] " #x "\n", \
- __FILE__, __LINE__, ++fns_trace_num)
-#else
-#define NSTRACE(x)
-#endif
#ifdef HAVE_NS
@@ -364,7 +357,7 @@ static void
x_set_icon_name (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
{
NSView *view = FRAME_NS_VIEW (f);
- NSTRACE (x_set_icon_name);
+ NSTRACE ("x_set_icon_name");
/* see if it's changed */
if (STRINGP (arg))
@@ -436,7 +429,7 @@ ns_set_name_internal (struct frame *f, Lisp_Object name)
static void
ns_set_name (struct frame *f, Lisp_Object name, int explicit)
{
- NSTRACE (ns_set_name);
+ NSTRACE ("ns_set_name");
/* Make sure that requests from lisp code override requests from
Emacs redisplay code. */
@@ -477,7 +470,7 @@ ns_set_name (struct frame *f, Lisp_Object name, int
explicit)
static void
x_explicitly_set_name (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
{
- NSTRACE (x_explicitly_set_name);
+ NSTRACE ("x_explicitly_set_name");
ns_set_name (f, arg, 1);
}
@@ -488,7 +481,7 @@ x_explicitly_set_name (struct frame *f, Lisp_Object arg,
Lisp_Object oldval)
void
x_implicitly_set_name (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
{
- NSTRACE (x_implicitly_set_name);
+ NSTRACE ("x_implicitly_set_name");
/* Deal with NS specific format t. */
if (FRAME_NS_P (f) && ((FRAME_ICONIFIED_P (f) && EQ (Vicon_title_format, Qt))
@@ -505,7 +498,7 @@ x_implicitly_set_name (struct frame *f, Lisp_Object arg,
Lisp_Object oldval)
static void
x_set_title (struct frame *f, Lisp_Object name, Lisp_Object old_name)
{
- NSTRACE (x_set_title);
+ NSTRACE ("x_set_title");
/* Don't change the title if it's already NAME. */
if (EQ (name, f->title))
return;
@@ -533,7 +526,7 @@ ns_set_name_as_filename (struct frame *f)
NSAutoreleasePool *pool;
Lisp_Object encoded_name, encoded_filename;
NSString *str;
- NSTRACE (ns_set_name_as_filename);
+ NSTRACE ("ns_set_name_as_filename");
if (f->explicit_name || ! NILP (f->title))
return;
@@ -729,7 +722,7 @@ ns_implicitly_set_icon_type (struct frame *f)
NSAutoreleasePool *pool;
BOOL setMini = YES;
- NSTRACE (ns_implicitly_set_icon_type);
+ NSTRACE ("ns_implicitly_set_icon_type");
block_input ();
pool = [[NSAutoreleasePool alloc] init];
@@ -797,7 +790,7 @@ x_set_icon_type (struct frame *f, Lisp_Object arg,
Lisp_Object oldval)
id image = nil;
BOOL setMini = YES;
- NSTRACE (x_set_icon_type);
+ NSTRACE ("x_set_icon_type");
if (!NILP (arg) && SYMBOLP (arg))
{
@@ -1305,6 +1298,8 @@ This function is an internal primitive--use `make-frame'
instead. */)
= [NSCursor arrowCursor];
f->output_data.ns->current_pointer = f->output_data.ns->text_cursor;
+ f->output_data.ns->in_animation = NO;
+
[[EmacsView alloc] initFrameFromEmacs: f];
x_icon (f, parms);
diff --git a/src/nsimage.m b/src/nsimage.m
index 9eaeefe..e76a7db 100644
--- a/src/nsimage.m
+++ b/src/nsimage.m
@@ -35,14 +35,6 @@ GNUstep port and post-20 update by Adrian Robert
(address@hidden)
#include "frame.h"
#include "coding.h"
-/* call tracing */
-#if 0
-int image_trace_num = 0;
-#define NSTRACE(x) fprintf (stderr, "%s:%d: [%d] " #x "\n", \
- __FILE__, __LINE__, ++image_trace_num)
-#else
-#define NSTRACE(x)
-#endif
/* ==========================================================================
@@ -57,7 +49,7 @@ void *
ns_image_from_XBM (unsigned char *bits, int width, int height,
unsigned long fg, unsigned long bg)
{
- NSTRACE (ns_image_from_XBM);
+ NSTRACE ("ns_image_from_XBM");
return [[EmacsImage alloc] initFromXBM: bits
width: width height: height
fg: fg bg: bg];
@@ -66,7 +58,7 @@ ns_image_from_XBM (unsigned char *bits, int width, int height,
void *
ns_image_for_XPM (int width, int height, int depth)
{
- NSTRACE (ns_image_for_XPM);
+ NSTRACE ("ns_image_for_XPM");
return [[EmacsImage alloc] initForXPMWithDepth: depth
width: width height: height];
}
@@ -74,7 +66,7 @@ ns_image_for_XPM (int width, int height, int depth)
void *
ns_image_from_file (Lisp_Object file)
{
- NSTRACE (ns_image_from_bitmap_file);
+ NSTRACE ("ns_image_from_bitmap_file");
return [EmacsImage allocInitFromFile: file];
}
@@ -85,7 +77,7 @@ ns_load_image (struct frame *f, struct image *img,
EmacsImage *eImg = nil;
NSSize size;
- NSTRACE (ns_load_image);
+ NSTRACE ("ns_load_image");
if (STRINGP (spec_file))
{
diff --git a/src/nsmenu.m b/src/nsmenu.m
index b5cb64d..ddc5dc2 100644
--- a/src/nsmenu.m
+++ b/src/nsmenu.m
@@ -45,13 +45,6 @@ Carbon version by Yamamoto Mitsuharu. */
#include <sys/types.h>
#endif
-#if 0
-int menu_trace_num = 0;
-#define NSTRACE(x) fprintf (stderr, "%s:%d: [%d] " #x "\n", \
- __FILE__, __LINE__, ++menu_trace_num)
-#else
-#define NSTRACE(x)
-#endif
#if 0
/* Include lisp -> C common menu parsing code */
@@ -121,7 +114,7 @@ ns_update_menubar (struct frame *f, bool deep_p, EmacsMenu
*submenu)
long t;
#endif
- NSTRACE (ns_update_menubar);
+ NSTRACE ("ns_update_menubar");
if (f != SELECTED_FRAME ())
return;
@@ -801,6 +794,8 @@ ns_menu_show (struct frame *f, int x, int y, int menuflags,
widget_value *wv, *first_wv = 0;
bool keymaps = (menuflags & MENU_KEYMAPS);
+ NSTRACE ("ns_menu_show");
+
block_input ();
p.x = x; p.y = y;
@@ -1003,10 +998,20 @@ free_frame_tool_bar (struct frame *f)
--------------------------------------------------------------------------
*/
{
EmacsView *view = FRAME_NS_VIEW (f);
+
+ NSTRACE ("free_frame_tool_bar");
+
block_input ();
view->wait_for_tool_bar = NO;
- [[view toolbar] setVisible: NO];
+
FRAME_TOOLBAR_HEIGHT (f) = 0;
+
+ /* Note: This trigger an animation, which calls windowDidResize
+ repeatedly. */
+ f->output_data.ns->in_animation = 1;
+ [[view toolbar] setVisible: NO];
+ f->output_data.ns->in_animation = 0;
+
unblock_input ();
}
@@ -1022,6 +1027,8 @@ update_frame_tool_bar (struct frame *f)
EmacsToolbar *toolbar = [view toolbar];
int oldh;
+ NSTRACE ("update_frame_tool_bar");
+
if (view == nil || toolbar == nil) return;
block_input ();
@@ -1101,7 +1108,11 @@ update_frame_tool_bar (struct frame *f)
}
if (![toolbar isVisible])
+ {
+ f->output_data.ns->in_animation = 1;
[toolbar setVisible: YES];
+ f->output_data.ns->in_animation = 0;
+ }
#ifdef NS_IMPL_COCOA
if ([toolbar changed])
@@ -1155,6 +1166,8 @@ update_frame_tool_bar (struct frame *f)
- initForView: (EmacsView *)view withIdentifier: (NSString *)identifier
{
+ NSTRACE ("[EmacsToolbar initForView: withIdentifier:]");
+
self = [super initWithIdentifier: identifier];
emacsView = view;
[self setDisplayMode: NSToolbarDisplayModeIconOnly];
@@ -1169,6 +1182,8 @@ update_frame_tool_bar (struct frame *f)
- (void)dealloc
{
+ NSTRACE ("[EmacsToolbar dealloc]");
+
[prevIdentifiers release];
[activeIdentifiers release];
[identifierToItem release];
@@ -1177,6 +1192,8 @@ update_frame_tool_bar (struct frame *f)
- (void) clearActive
{
+ NSTRACE ("[EmacsToolbar clearActive]");
+
[prevIdentifiers release];
prevIdentifiers = [activeIdentifiers copy];
[activeIdentifiers removeAllObjects];
@@ -1186,6 +1203,8 @@ update_frame_tool_bar (struct frame *f)
- (void) clearAll
{
+ NSTRACE ("[EmacsToolbar clearAll]");
+
[self clearActive];
while ([[self items] count] > 0)
[self removeItemAtIndex: 0];
@@ -1193,6 +1212,8 @@ update_frame_tool_bar (struct frame *f)
- (BOOL) changed
{
+ NSTRACE ("[EmacsToolbar changed]");
+
return [activeIdentifiers isEqualToArray: prevIdentifiers] &&
enablement == prevEnablement ? NO : YES;
}
@@ -1203,6 +1224,8 @@ update_frame_tool_bar (struct frame *f)
helpText: (const char *)help
enabled: (BOOL)enabled
{
+ NSTRACE ("[EmacsToolbar addDisplayItemWithImage: ...]");
+
/* 1) come up w/identifier */
NSString *identifier
= [NSString stringWithFormat: @"%lu", (unsigned long)[img hash]];
@@ -1236,6 +1259,7 @@ update_frame_tool_bar (struct frame *f)
all items to enabled state (for some reason). */
- (void)validateVisibleItems
{
+ NSTRACE ("[EmacsToolbar validateVisibleItems]");
}
@@ -1245,12 +1269,16 @@ update_frame_tool_bar (struct frame *f)
itemForItemIdentifier: (NSString *)itemIdentifier
willBeInsertedIntoToolbar: (BOOL)flag
{
+ NSTRACE ("[EmacsToolbar toolbar: ...]");
+
/* look up NSToolbarItem by identifier and return... */
return [identifierToItem objectForKey: itemIdentifier];
}
- (NSArray *)toolbarDefaultItemIdentifiers: (NSToolbar *)toolbar
{
+ NSTRACE ("[EmacsToolbar toolbarDefaultItemIdentifiers:]");
+
/* return entire set.. */
return activeIdentifiers;
}
@@ -1258,6 +1286,8 @@ update_frame_tool_bar (struct frame *f)
/* for configuration palette (not yet supported) */
- (NSArray *)toolbarAllowedItemIdentifiers: (NSToolbar *)toolbar
{
+ NSTRACE ("[EmacsToolbar toolbarAllowedItemIdentifiers:]");
+
/* return entire set... */
return activeIdentifiers;
//return [identifierToItem allKeys];
@@ -1423,7 +1453,7 @@ ns_popup_dialog (struct frame *f, Lisp_Object header,
Lisp_Object contents)
BOOL isQ;
NSAutoreleasePool *pool;
- NSTRACE (x-popup-dialog);
+ NSTRACE ("ns_popup_dialog");
isQ = NILP (header);
diff --git a/src/nsterm.h b/src/nsterm.h
index c06b7c4..3fb8cfc 100644
--- a/src/nsterm.h
+++ b/src/nsterm.h
@@ -61,6 +61,243 @@ typedef float EmacsCGFloat;
/* ==========================================================================
+ Trace support
+
+ ==========================================================================
*/
+
+/* Uncomment the following line to enable trace.
+
+ Hint: keep the trailing whitespace -- the version control system
+ will reject accidental commits. */
+
+/* #define NSTRACE_ENABLED 1 */
+
+
+/* Print a call tree containing all annotated functions.
+
+ The call structure of the functions is represented using
+ indentation and vertical lines. Extra information is printed using
+ horizontal lines that connect to the vertical line.
+
+ The return value is represented using the arrow "->>". For simple
+ functions, the arrow can be printed on the same line as the
+ function name. If more output is printed, it is connected to the
+ vertical line of the function.
+
+ The first column contains the file name, the second the line
+ number, and the third a number increasing for each trace line.
+
+ Note that the trace system, when enabled, use the GCC/Clang
+ "cleanup" extension.
+
+ For example (long lines manually split to reduce width):
+
+nsterm.m : 1600: [ 4428] ns_fullscreen_hook
+nsterm.m : 7006: [ 4429] | handleFS
+nsterm.m : 7035: [ 4430] | +--- FULLSCREEN_MAXIMIZED
+nsterm.m : 7627: [ 4431] | | performZoom
+nsterm.m : 7636: [ 4432] | | | zoom
+nsterm.m : 874: [ 4433] | | | | ns_update_auto_hide_menu_bar
+nsterm.m : 6615: [ 4434] | | | | [windowWillUseStandardFrame:
+ defaultFrame:(X:0 Y:0)/(W:1600 H:1177)]
+nsterm.m : 99: [ 4435] | | | | +--- fs_state: FULLSCREEN_NONE
+nsterm.m : 119: [ 4436] | | | | +--- fs_before_fs: -1
+nsterm.m : 115: [ 4437] | | | | +--- next_maximized: FULLSCREEN_MAXIMIZED
+nsterm.m : 6619: [ 4438] | | | | +--- ns_userRect: (X:0 Y:0)/(W:0 H:0)
+nsterm.m : 6620: [ 4439] | | | | +--- [sender frame]:
+ (X:0 Y:626)/(W:595 H:551)
+nsterm.m : 6644: [ 4440] | | | | +--- ns_userRect (2):
+ (X:0 Y:626)/(W:595 H:551)
+nsterm.m : 6684: [ 4441] | | | | +--- FULLSCREEN_MAXIMIZED
+nsterm.m : 7057: [ 4442] | | | | | setFSValue
+nsterm.m : 115: [ 4443] | | | | | +--- value: FULLSCREEN_MAXIMIZED
+nsterm.m : 6711: [ 4444] | | | | +--- Final ns_userRect:
+ (X:0 Y:626)/(W:595 H:551)
+nsterm.m : 6712: [ 4445] | | | | +--- Final maximized_width: 1600
+nsterm.m : 6713: [ 4446] | | | | +--- Final maximized_height: 1177
+nsterm.m : 119: [ 4447] | | | | +--- Final next_maximized: -1
+nsterm.m : 6209: [ 4448] | | | | | windowWillResize: toSize: (W:1600 H:1177)
+nsterm.m : 6210: [ 4449] | | | | | +--- [sender frame]:
+ (X:0 Y:626)/(W:595 H:551)
+nsterm.m : 115: [ 4450] | | | | | +--- fs_state: FULLSCREEN_MAXIMIZED
+nsterm.m : 6274: [ 4451] | | | | | +--- cols: 223 rows: 79
+nsterm.m : 6299: [ 4452] | | | | | +->> (W:1596 H:1167)
+nsterm.m : 6718: [ 4453] | | | | +->> (X:0 Y:0)/(W:1600 H:1177)
+
+ Here, "ns_fullscreen_hook" calls "handleFS", which is turn calls
+ "performZoom". This function calls "[super performZoom]", which
+ isn't annoted (so it doesn't show up in the trace). However, it
+ calls "zoom" which is annotated so it is part of the call trace.
+ Later, the method "windowWillUseStandardFrame" and the function
+ "setFSValue" are called. The lines with "+---" contain extra
+ information and lines containing "->>" represent return values. */
+
+#ifndef NSTRACE_ENABLED
+#define NSTRACE_ENABLED 0
+#endif
+
+#if NSTRACE_ENABLED
+extern int nstrace_num;
+extern int nstrace_depth;
+
+void nstrace_leave(int *);
+
+/* printf-style trace output. Output is aligned with contained heading. */
+#define NSTRACE_MSG_NO_DASHES(...) \
+ do \
+ { \
+ if (nstrace_enabled) \
+ { \
+ fprintf (stderr, "%-10s:%5d: [%5d]%.*s", \
+ __FILE__, __LINE__, ++nstrace_num, \
+ 2*nstrace_depth, " | | | | | | | | | | | | | | | .."); \
+ fprintf (stderr, __VA_ARGS__); \
+ fprintf (stderr, "\n"); \
+ } \
+ } \
+ while(0)
+
+#define NSTRACE_MSG(...) NSTRACE_MSG_NO_DASHES("+--- " __VA_ARGS__)
+
+
+
+/* Macros for printing complex types.
+
+ NSTRACE_FMT_what -- Printf format string for "what".
+ NSTRACE_ARG_what(x) -- Printf argument for "what". */
+
+#define NSTRACE_FMT_SIZE "(W:%.0f H:%.0f)"
+#define NSTRACE_ARG_SIZE(elt) (elt).width, (elt).height
+
+#define NSTRACE_FMT_POINT "(X:%.0f Y:%.0f)"
+#define NSTRACE_ARG_POINT(elt) (elt).x, (elt).y
+
+#define NSTRACE_FMT_RECT NSTRACE_FMT_POINT "/" NSTRACE_FMT_SIZE
+#define NSTRACE_ARG_RECT(elt) \
+ NSTRACE_ARG_POINT((elt).origin), NSTRACE_ARG_SIZE((elt).size)
+
+
+/* Macros for printing complex types as extra information. */
+
+#define NSTRACE_SIZE(str,size) \
+ NSTRACE_MSG (str ": " NSTRACE_FMT_SIZE, \
+ NSTRACE_ARG_SIZE (size));
+
+#define NSTRACE_POINT(str,point) \
+ NSTRACE_MSG (str ": " NSTRACE_FMT_POINT, \
+ NSTRACE_ARG_POINT (point));
+
+#define NSTRACE_RECT(str,rect) \
+ NSTRACE_MSG (str ": " NSTRACE_FMT_RECT, \
+ NSTRACE_ARG_RECT (rect));
+
+#define NSTRACE_FSTYPE(str,fs_type) \
+ do \
+ { \
+ if (nstrace_enabled) \
+ { \
+ ns_print_fullscreen_type_name(str, fs_type); \
+ } \
+ } \
+ while(0)
+
+
+/* Return value macros.
+
+ NSTRACE_RETURN(fmt, ...) - Print a return value, support printf-style
+ format string and arguments.
+
+ NSTRACE_RETURN_what(obj) - Print a return value of kind WHAT.
+
+ NSTRACE_FMT_RETURN - A string literal representing a returned
+ value. Useful when creating a format string
+ to printf-like constructs like NSTRACE(). */
+
+#define NSTRACE_FMT_RETURN "->>"
+
+#define NSTRACE_RETURN(...) \
+ NSTRACE_MSG_NO_DASHES ("+" NSTRACE_FMT_RETURN " " __VA_ARGS__)
+
+#define NSTRACE_RETURN_SIZE(size) \
+ NSTRACE_RETURN(NSTRACE_FMT_SIZE, NSTRACE_ARG_SIZE(size))
+
+#define NSTRACE_RETURN_POINT(point) \
+ NSTRACE_RETURN(NSTRACE_FMT_POINT, NSTRACE_ARG_POINT(point))
+
+#define NSTRACE_RETURN_RECT(rect) \
+ NSTRACE_RETURN(NSTRACE_FMT_RECT, NSTRACE_ARG_RECT(rect))
+
+
+/* Function enter macros.
+
+ NSTRACE (fmt, ...) -- Enable trace output in curent block
+ (typically a function). Accepts printf-style
+ arguments.
+
+ NSTRACE_WHEN (cond, fmt, ...) -- Enable trace output when COND is true.
+
+ NSTRACE_UNLESS (cond, fmt, ...) -- Enable trace output unless COND is
+ true. */
+
+
+
+#define NSTRACE_WHEN(cond, ...) \
+ __attribute__((cleanup(nstrace_leave))) \
+ int nstrace_enabled = (cond); \
+ if (nstrace_enabled) { ++nstrace_depth; } \
+ NSTRACE_MSG_NO_DASHES(__VA_ARGS__);
+
+#endif /* NSTRACE_ENABLED */
+
+#define NSTRACE(...) NSTRACE_WHEN(1, __VA_ARGS__)
+#define NSTRACE_UNLESS(cond, ...) NSTRACE_WHEN(!(cond), __VA_ARGS__)
+
+
+/* Non-trace replacement versions. */
+#ifndef NSTRACE_WHEN
+#define NSTRACE_WHEN(...)
+#endif
+
+#ifndef NSTRACE_MSG
+#define NSTRACE_MSG(...)
+#endif
+
+#ifndef NSTRACE_SIZE
+#define NSTRACE_SIZE(str,size)
+#endif
+
+#ifndef NSTRACE_POINT
+#define NSTRACE_POINT(str,point)
+#endif
+
+#ifndef NSTRACE_RECT
+#define NSTRACE_RECT(str,rect)
+#endif
+
+#ifndef NSTRACE_FSTYPE
+#define NSTRACE_FSTYPE(str,fs_type)
+#endif
+
+#ifndef NSTRACE_RETURN_SIZE
+#define NSTRACE_RETURN_SIZE(size)
+#endif
+
+#ifndef NSTRACE_RETURN_POINT
+#define NSTRACE_RETURN_POINT(point)
+#endif
+
+#ifndef NSTRACE_RETURN_RECT
+#define NSTRACE_RETURN_RECT(rect)
+#endif
+
+#ifndef NSTRACE_RETURN_FSTYPE
+#define NSTRACE_RETURN_FSTYPE(fs_type)
+#endif
+
+
+
+/* ==========================================================================
+
NSColor, EmacsColor category.
==========================================================================
*/
@@ -174,6 +411,7 @@ typedef float EmacsCGFloat;
#ifdef NS_IMPL_GNUSTEP
- (void)windowDidMove: (id)sender;
#endif
+- (int)fullscreenState;
@end
@@ -678,6 +916,9 @@ struct ns_output
/* Non-zero if we are zooming (maximizing) the frame. */
int zooming;
+
+ /* Non-zero if we are doing an animation, e.g. toggling the tool bar. */
+ int in_animation;
};
/* this dummy decl needed to support TTYs */
diff --git a/src/nsterm.m b/src/nsterm.m
index c4bfd7c..925e9af 100644
--- a/src/nsterm.m
+++ b/src/nsterm.m
@@ -68,38 +68,60 @@ GNUstep port and post-20 update by Adrian Robert
(address@hidden)
#include "macfont.h"
#endif
-/* call tracing */
-#if 0
-int term_trace_num = 0;
-#define NSTRACE(x) fprintf (stderr, "%s:%d: [%d] " #x "\n", \
- __FILE__, __LINE__, ++term_trace_num)
-#else
-#define NSTRACE(x)
-#endif
-/* Detailed tracing. "S" means "size" and "LL" stands for "lower left". */
-#if 0
-int term_trace_num = 0;
-#define NSTRACE_SIZE(str,size) fprintf (stderr, \
- "%s:%d: [%d] " str \
- " (S:%.0f x %.0f)\n", \
- __FILE__, __LINE__, ++term_trace_num,\
- size.height, \
- size.width)
-#define NSTRACE_RECT(s,r) fprintf (stderr, \
- "%s:%d: [%d] " s \
- " (LL:%.0f x %.0f -> S:%.0f x %.0f)\n", \
- __FILE__, __LINE__, ++term_trace_num,\
- r.origin.x, \
- r.origin.y, \
- r.size.height, \
- r.size.width)
-#else
-#define NSTRACE_SIZE(str,size)
-#define NSTRACE_RECT(s,r)
+extern NSString *NSMenuDidBeginTrackingNotification;
+
+
+#if NSTRACE_ENABLED
+int nstrace_num = 0;
+int nstrace_depth = 0;
+
+/* Called when nstrace_enabled goes out of scope. */
+void nstrace_leave(int * pointer_to_nstrace_enabled)
+{
+ if (*pointer_to_nstrace_enabled)
+ {
+ --nstrace_depth;
+ }
+}
+
+
+void ns_print_fullscreen_type_name (char const * s, int fs_type)
+{
+ // This is a support function for the NSTRACE system, don't add a
+ // NSTRACE () here. However, a local `nstrace_enabled' variable is
+ // needed by the NSTRACE_MSG macros.
+ int nstrace_enabled = 1;
+
+ switch (fs_type)
+ {
+ case FULLSCREEN_NONE:
+ NSTRACE_MSG ("%s: FULLSCREEN_NONE", s);
+ break;
+
+ case FULLSCREEN_WIDTH:
+ NSTRACE_MSG ("%s: FULLSCREEN_WIDTH", s);
+ break;
+
+ case FULLSCREEN_HEIGHT:
+ NSTRACE_MSG ("%s: FULLSCREEN_HEIGHT", s);
+ break;
+
+ case FULLSCREEN_BOTH:
+ NSTRACE_MSG ("%s: FULLSCREEN_BOTH", s);
+ break;
+
+ case FULLSCREEN_MAXIMIZED:
+ NSTRACE_MSG ("%s: FULLSCREEN_MAXIMIZED", s);
+ break;
+
+ default:
+ NSTRACE_MSG ("%s: %d", s, fs_type);
+ break;
+ }
+}
#endif
-extern NSString *NSMenuDidBeginTrackingNotification;
/* ==========================================================================
@@ -242,7 +264,7 @@ static struct frame *ns_updating_frame;
static NSView *focus_view = NULL;
static int ns_window_num = 0;
#ifdef NS_IMPL_GNUSTEP
-static NSRect uRect;
+static NSRect uRect; // TODO: This is dead, remove it?
#endif
static BOOL gsaved = NO;
static BOOL ns_fake_keydown = NO;
@@ -622,6 +644,46 @@ ns_release_autorelease_pool (void *pool)
}
+/* True, if the menu bar should be hidden. */
+
+static BOOL
+ns_menu_bar_should_be_hidden (void)
+{
+ return !NILP (ns_auto_hide_menu_bar)
+ && [NSApp respondsToSelector:@selector(setPresentationOptions:)];
+}
+
+
+static CGFloat
+ns_menu_bar_height (NSScreen *screen)
+/* The height of the menu bar, if visible. */
+{
+ // NSTRACE ("ns_menu_bar_height");
+
+ CGFloat res;
+
+ if (ns_menu_bar_should_be_hidden())
+ {
+ res = 0;
+ }
+ else
+ {
+ NSRect screenFrame = [screen frame];
+ NSRect screenVisibleFrame = [screen visibleFrame];
+
+ CGFloat frameTop = screenFrame.origin.y + screenFrame.size.height;
+ CGFloat visibleFrameTop = (screenVisibleFrame.origin.y
+ + screenVisibleFrame.size.height);
+
+ res = frameTop - visibleFrameTop;
+
+ }
+
+ // NSTRACE_MSG (NSTRACE_FMT_RETURN "%.0f", res);
+
+ return res;
+}
+
/* ==========================================================================
@@ -671,32 +733,132 @@ ns_release_autorelease_pool (void *pool)
// Result: Menu bar visible, frame placed immediately below the menu.
//
+static NSRect constrain_frame_rect(NSRect frameRect)
+{
+ NSTRACE ("constrain_frame_rect(" NSTRACE_FMT_RECT ")",
+ NSTRACE_ARG_RECT (frameRect));
+
+ // --------------------
+ // Collect information about the screen the frame is covering.
+ //
+
+ NSArray *screens = [NSScreen screens];
+ NSUInteger nr_screens = [screens count];
+
+ int i;
+
+ // The height of the menu bar, if present in any screen the frame is
+ // displayed in.
+ int menu_bar_height = 0;
+
+ // A rectangle covering all the screen the frame is displayed in.
+ NSRect multiscreenRect = NSMakeRect(0, 0, 0, 0);
+ for (i = 0; i < nr_screens; ++i )
+ {
+ NSScreen *s = [screens objectAtIndex: i];
+ NSRect scrRect = [s frame];
+
+ NSTRACE_MSG ("Screen %d: " NSTRACE_FMT_RECT,
+ i, NSTRACE_ARG_RECT (scrRect));
+
+ if (NSIntersectionRect (frameRect, scrRect).size.height != 0)
+ {
+ multiscreenRect = NSUnionRect (multiscreenRect, scrRect);
+
+ menu_bar_height = max(menu_bar_height, ns_menu_bar_height (s));
+ }
+ }
+
+ NSTRACE_RECT ("multiscreenRect", multiscreenRect);
+
+ NSTRACE_MSG ("menu_bar_height: %d", menu_bar_height);
+
+ if (multiscreenRect.size.width == 0
+ || multiscreenRect.size.height == 0)
+ {
+ // Failed to find any monitor, give up.
+ NSTRACE_MSG ("multiscreenRect empty");
+ NSTRACE_RETURN_RECT (frameRect);
+ return frameRect;
+ }
+
+
+ // --------------------
+ // Find a suitable placement.
+ //
+
+ if (ns_menu_bar_should_be_hidden())
+ {
+ // When the menu bar is hidden, the user may place part of the
+ // frame above the top of the screen, for example to hide the
+ // title bar.
+ //
+ // Hence, keep the original position.
+ }
+ else
+ {
+ // Ensure that the frame is below the menu bar, or below the top
+ // of the screen.
+ //
+ // This assume that the menu bar is placed at the top in the
+ // rectangle that covers the monitors. (It doesn't have to be,
+ // but if it's not it's hard to do anything useful.)
+ CGFloat topOfWorkArea = (multiscreenRect.origin.y
+ + multiscreenRect.size.height
+ - menu_bar_height);
+
+ CGFloat topOfFrame = frameRect.origin.y + frameRect.size.height;
+ if (topOfFrame > topOfWorkArea)
+ {
+ frameRect.origin.y -= topOfFrame - topOfWorkArea;
+ NSTRACE_RECT ("After placement adjust", frameRect);
+ }
+ }
+
+ // Include the following section to restrict frame to the screens.
+ // (If so, update it to allow the frame to stretch down below the
+ // screen.)
+#if 0
+ // --------------------
+ // Ensure frame doesn't stretch below the screens.
+ //
+
+ CGFloat diff = multiscreenRect.origin.y - frameRect.origin.y;
+
+ if (diff > 0)
+ {
+ frameRect.origin.y = multiscreenRect.origin.y;
+ frameRect.size.height -= diff;
+ }
+#endif
+
+ NSTRACE_RETURN_RECT (frameRect);
+ return frameRect;
+}
+
+
static void
ns_constrain_all_frames (void)
{
Lisp_Object tail, frame;
+ NSTRACE ("ns_constrain_all_frames");
+
+ block_input ();
+
FOR_EACH_FRAME (tail, frame)
{
struct frame *f = XFRAME (frame);
if (FRAME_NS_P (f))
{
NSView *view = FRAME_NS_VIEW (f);
- /* This no-op will trigger the default window placing
- * constraint system. */
- [[view window] setFrameOrigin:[[view window] frame].origin];
+
+ [[view window] setFrame:constrain_frame_rect([[view window] frame])
+ display:NO];
}
}
-}
-
-
-/* True, if the menu bar should be hidden. */
-static BOOL
-ns_menu_bar_should_be_hidden (void)
-{
- return !NILP (ns_auto_hide_menu_bar)
- && [NSApp respondsToSelector:@selector(setPresentationOptions:)];
+ unblock_input ();
}
@@ -706,9 +868,9 @@ static void
ns_update_auto_hide_menu_bar (void)
{
#ifdef NS_IMPL_COCOA
- block_input ();
+ NSTRACE ("ns_update_auto_hide_menu_bar");
- NSTRACE (ns_update_auto_hide_menu_bar);
+ block_input ();
if (NSApp != nil && [NSApp isActive])
{
@@ -749,7 +911,7 @@ ns_update_begin (struct frame *f)
--------------------------------------------------------------------------
*/
{
EmacsView *view = FRAME_NS_VIEW (f);
- NSTRACE (ns_update_begin);
+ NSTRACE ("ns_update_begin");
ns_update_auto_hide_menu_bar ();
@@ -806,7 +968,7 @@ ns_update_window_begin (struct window *w)
struct frame *f = XFRAME (WINDOW_FRAME (w));
Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (f);
- NSTRACE (ns_update_window_begin);
+ NSTRACE ("ns_update_window_begin");
w->output_cursor = w->cursor;
block_input ();
@@ -836,6 +998,8 @@ ns_update_window_end (struct window *w, bool cursor_on_p,
external (RIF) call; for one window called before update_end
--------------------------------------------------------------------------
*/
{
+ NSTRACE ("update_window_end");
+
/* note: this fn is nearly identical in all terms */
if (!w->pseudo_window_p)
{
@@ -861,8 +1025,6 @@ ns_update_window_end (struct window *w, bool cursor_on_p,
frame_up_to_date to redisplay the mouse highlight. */
if (mouse_face_overwritten_p)
reset_mouse_highlight (MOUSE_HL_INFO (XFRAME (w->frame)));
-
- NSTRACE (update_window_end);
}
@@ -875,6 +1037,8 @@ ns_update_end (struct frame *f)
{
EmacsView *view = FRAME_NS_VIEW (f);
+ NSTRACE ("ns_update_end");
+
/* if (f == MOUSE_HL_INFO (f)->mouse_face_mouse_frame) */
MOUSE_HL_INFO (f)->mouse_face_defer = 0;
@@ -885,7 +1049,6 @@ ns_update_end (struct frame *f)
unblock_input ();
ns_updating_frame = NULL;
- NSTRACE (ns_update_end);
}
static void
@@ -899,7 +1062,7 @@ ns_focus (struct frame *f, NSRect *r, int n)
the entire window.
--------------------------------------------------------------------------
*/
{
-// NSTRACE (ns_focus);
+// NSTRACE ("ns_focus");
/* static int c =0;
fprintf (stderr, "focus: %d", c++);
if (r) fprintf (stderr, " (%.0f, %.0f : %.0f x %.0f)", r->origin.x,
r->origin.y, r->size.width, r->size.height);
@@ -943,7 +1106,7 @@ ns_unfocus (struct frame *f)
Internal: Remove focus on given frame
--------------------------------------------------------------------------
*/
{
-// NSTRACE (ns_unfocus);
+// NSTRACE ("ns_unfocus");
if (gsaved)
{
@@ -993,7 +1156,7 @@ ns_ring_bell (struct frame *f)
"Beep" routine
--------------------------------------------------------------------------
*/
{
- NSTRACE (ns_ring_bell);
+ NSTRACE ("ns_ring_bell");
if (visible_bell)
{
NSAutoreleasePool *pool;
@@ -1079,7 +1242,7 @@ ns_frame_raise_lower (struct frame *f, bool raise)
External (hook)
--------------------------------------------------------------------------
*/
{
- NSTRACE (ns_frame_raise_lower);
+ NSTRACE ("ns_frame_raise_lower");
if (raise)
ns_raise_frame (f);
@@ -1097,7 +1260,7 @@ ns_frame_rehighlight (struct frame *frame)
struct ns_display_info *dpyinfo = FRAME_DISPLAY_INFO (frame);
struct frame *old_highlight = dpyinfo->x_highlight_frame;
- NSTRACE (ns_frame_rehighlight);
+ NSTRACE ("ns_frame_rehighlight");
if (dpyinfo->x_focus_frame)
{
dpyinfo->x_highlight_frame
@@ -1136,7 +1299,7 @@ x_make_frame_visible (struct frame *f)
External: Show the window (X11 semantics)
--------------------------------------------------------------------------
*/
{
- NSTRACE (x_make_frame_visible);
+ NSTRACE ("x_make_frame_visible");
/* XXX: at some points in past this was not needed, as the only place that
called this (frame.c:Fraise_frame ()) also called raise_lower;
if this ends up the case again, comment this out again. */
@@ -1170,7 +1333,7 @@ x_make_frame_invisible (struct frame *f)
--------------------------------------------------------------------------
*/
{
NSView *view;
- NSTRACE (x_make_frame_invisible);
+ NSTRACE ("x_make_frame_invisible");
check_window_system (f);
view = FRAME_NS_VIEW (f);
[[view window] orderOut: NSApp];
@@ -1188,7 +1351,7 @@ x_iconify_frame (struct frame *f)
NSView *view;
struct ns_display_info *dpyinfo;
- NSTRACE (x_iconify_frame);
+ NSTRACE ("x_iconify_frame");
check_window_system (f);
view = FRAME_NS_VIEW (f);
dpyinfo = FRAME_DISPLAY_INFO (f);
@@ -1220,7 +1383,7 @@ x_free_frame_resources (struct frame *f)
struct ns_display_info *dpyinfo;
Mouse_HLInfo *hlinfo;
- NSTRACE (x_free_frame_resources);
+ NSTRACE ("x_free_frame_resources");
check_window_system (f);
view = FRAME_NS_VIEW (f);
dpyinfo = FRAME_DISPLAY_INFO (f);
@@ -1257,7 +1420,7 @@ x_destroy_window (struct frame *f)
External: Delete the window
--------------------------------------------------------------------------
*/
{
- NSTRACE (x_destroy_window);
+ NSTRACE ("x_destroy_window");
check_window_system (f);
x_free_frame_resources (f);
ns_window_num--;
@@ -1275,7 +1438,7 @@ x_set_offset (struct frame *f, int xoff, int yoff, int
change_grav)
NSScreen *fscreen = [screens objectAtIndex: 0];
NSScreen *screen = [[view window] screen];
- NSTRACE (x_set_offset);
+ NSTRACE ("x_set_offset");
block_input ();
@@ -1301,10 +1464,11 @@ x_set_offset (struct frame *f, int xoff, int yoff, int
change_grav)
#endif
/* Constrain the setFrameTopLeftPoint so we don't move behind the
menu bar. */
- [[view window] setFrameTopLeftPoint:
- NSMakePoint (SCREENMAXBOUND (f->left_pos),
- SCREENMAXBOUND ([fscreen frame].size.height
- - NS_TOP_POS (f)))];
+ NSPoint pt = NSMakePoint (SCREENMAXBOUND (f->left_pos),
+ SCREENMAXBOUND ([fscreen frame].size.height
+ - NS_TOP_POS (f)));
+ NSTRACE_POINT ("setFrameTopLeftPoint", pt);
+ [[view window] setFrameTopLeftPoint: pt];
f->size_hint_flags &= ~(XNegative|YNegative);
}
@@ -1332,11 +1496,13 @@ x_set_window_size (struct frame *f,
int rows, cols;
int orig_height = wr.size.height;
- NSTRACE (x_set_window_size);
+ NSTRACE ("x_set_window_size");
if (view == nil)
return;
+ NSTRACE_RECT ("current", wr);
+
/*fprintf (stderr, "\tsetWindowSize: %d x %d, pixelwise %d, font size %d x
%d\n", width, height, pixelwise, FRAME_COLUMN_WIDTH (f), FRAME_LINE_HEIGHT
(f));*/
block_input ();
@@ -1397,7 +1563,7 @@ x_set_window_size (struct frame *f,
make_number (FRAME_NS_TITLEBAR_HEIGHT (f)),
make_number (FRAME_TOOLBAR_HEIGHT (f))));
- [view setRows: rows andColumns: cols];
+ NSTRACE_RECT ("setFrame", wr);
[window setFrame: wr display: YES];
/* This is a trick to compensate for Emacs' managing the scrollbar area
@@ -1412,6 +1578,7 @@ x_set_window_size (struct frame *f,
? NSMakePoint (FRAME_SCROLL_BAR_COLS (f) * FRAME_COLUMN_WIDTH (f)
- NS_SCROLL_BAR_WIDTH (f), 0)
: NSMakePoint (0, 0);
+ NSTRACE_RECT ("setFrame", wr);
[view setFrame: NSMakeRect (0, 0, pixelwidth, pixelheight)];
[view setBoundsOrigin: origin];
}
@@ -1426,6 +1593,8 @@ ns_fullscreen_hook (struct frame *f)
{
EmacsView *view = (EmacsView *)FRAME_NS_VIEW (f);
+ NSTRACE ("ns_fullscreen_hook");
+
if (!FRAME_VISIBLE_P (f))
return;
@@ -1672,7 +1841,7 @@ ns_lisp_to_color (Lisp_Object color, NSColor **col)
Convert a Lisp string object to a NS color
--------------------------------------------------------------------------
*/
{
- NSTRACE (ns_lisp_to_color);
+ NSTRACE ("ns_lisp_to_color");
if (STRINGP (color))
return ns_get_color (SSDATA (color), col);
else if (SYMBOLP (color))
@@ -1690,7 +1859,7 @@ ns_color_to_lisp (NSColor *col)
EmacsCGFloat red, green, blue, alpha, gray;
char buf[1024];
const char *str;
- NSTRACE (ns_color_to_lisp);
+ NSTRACE ("ns_color_to_lisp");
block_input ();
if ([[col colorSpaceName] isEqualToString: NSNamedColorSpace])
@@ -1758,7 +1927,7 @@ ns_defined_color (struct frame *f,
--------------------------------------------------------------------------
*/
{
NSColor *col;
- NSTRACE (ns_defined_color);
+ NSTRACE ("ns_defined_color");
block_input ();
if (ns_get_color (name, &col) != 0) /* Color not found */
@@ -1823,7 +1992,7 @@ frame_set_mouse_pixel_position (struct frame *f, int
pix_x, int pix_y)
Programmatically reposition mouse pointer in pixel coordinates
--------------------------------------------------------------------------
*/
{
- NSTRACE (frame_set_mouse_pixel_position);
+ NSTRACE ("frame_set_mouse_pixel_position");
ns_raise_frame (f);
#if 0
/* FIXME: this does not work, and what about GNUstep? */
@@ -1846,7 +2015,7 @@ note_mouse_movement (struct frame *frame, CGFloat x,
CGFloat y)
struct ns_display_info *dpyinfo = FRAME_DISPLAY_INFO (frame);
NSRect *r;
-// NSTRACE (note_mouse_movement);
+// NSTRACE ("note_mouse_movement");
dpyinfo->last_mouse_motion_frame = frame;
r = &dpyinfo->last_mouse_glyph;
@@ -1887,7 +2056,7 @@ ns_mouse_position (struct frame **fp, int insist,
Lisp_Object *bar_window,
struct frame *f;
struct ns_display_info *dpyinfo;
- NSTRACE (ns_mouse_position);
+ NSTRACE ("ns_mouse_position");
if (*fp == NULL)
{
@@ -1943,7 +2112,7 @@ ns_frame_up_to_date (struct frame *f)
Can't use FRAME_MOUSE_UPDATE due to ns_frame_begin and ns_frame_end calls.
--------------------------------------------------------------------------
*/
{
- NSTRACE (ns_frame_up_to_date);
+ NSTRACE ("ns_frame_up_to_date");
if (FRAME_NS_P (f))
{
@@ -1968,7 +2137,7 @@ ns_define_frame_cursor (struct frame *f, Cursor cursor)
External (RIF): set frame mouse pointer type.
--------------------------------------------------------------------------
*/
{
- NSTRACE (ns_define_frame_cursor);
+ NSTRACE ("ns_define_frame_cursor");
if (FRAME_POINTER_TYPE (f) != cursor)
{
EmacsView *view = FRAME_NS_VIEW (f);
@@ -2015,7 +2184,7 @@ x_get_keysym_name (int keysym)
--------------------------------------------------------------------------
*/
{
static char value[16];
- NSTRACE (x_get_keysym_name);
+ NSTRACE ("x_get_keysym_name");
sprintf (value, "%d", keysym);
return value;
}
@@ -2035,7 +2204,7 @@ ns_redraw_scroll_bars (struct frame *f)
int i;
id view;
NSArray *subviews = [[FRAME_NS_VIEW (f) superview] subviews];
- NSTRACE (ns_redraw_scroll_bars);
+ NSTRACE ("ns_redraw_scroll_bars");
for (i =[subviews count]-1; i >= 0; i--)
{
view = [subviews objectAtIndex: i];
@@ -2054,7 +2223,7 @@ ns_clear_frame (struct frame *f)
NSView *view = FRAME_NS_VIEW (f);
NSRect r;
- NSTRACE (ns_clear_frame);
+ NSTRACE ("ns_clear_frame");
/* comes on initial frame because we have
after-make-frame-functions = select-frame */
@@ -2090,7 +2259,7 @@ ns_clear_frame_area (struct frame *f, int x, int y, int
width, int height)
if (!view || !face)
return;
- NSTRACE (ns_clear_frame_area);
+ NSTRACE ("ns_clear_frame_area");
r = NSIntersectionRect (r, [view frame]);
ns_focus (f, &r, 1);
@@ -2124,7 +2293,7 @@ ns_scroll_run (struct window *w, struct run *run)
struct frame *f = XFRAME (w->frame);
int x, y, width, height, from_y, to_y, bottom_y;
- NSTRACE (ns_scroll_run);
+ NSTRACE ("ns_scroll_run");
/* begin copy from other terms */
/* Get frame-relative bounding box of the text display area of W,
@@ -2183,7 +2352,7 @@ ns_after_update_window_line (struct window *w, struct
glyph_row *desired_row)
struct frame *f;
int width, height;
- NSTRACE (ns_after_update_window_line);
+ NSTRACE ("ns_after_update_window_line");
/* begin copy from other terms */
eassert (w);
@@ -2224,7 +2393,7 @@ ns_shift_glyphs_for_insert (struct frame *f,
NSRect srcRect = NSMakeRect (x, y, width, height);
NSRect dstRect = NSMakeRect (x+shift_by, y, width, height);
- NSTRACE (ns_shift_glyphs_for_insert);
+ NSTRACE ("ns_shift_glyphs_for_insert");
ns_copy_bits (f, srcRect, dstRect);
}
@@ -2394,7 +2563,7 @@ ns_draw_window_cursor (struct window *w, struct glyph_row
*glyph_row,
in mini-buffer windows when switching between echo area glyphs
and mini-buffer. */
- NSTRACE (dumpcursor);
+ NSTRACE ("dumpcursor");
if (!on_p)
return;
@@ -2523,7 +2692,7 @@ ns_draw_vertical_window_border (struct window *w, int x,
int y0, int y1)
struct face *face;
NSRect r = NSMakeRect (x, y0, 1, y1-y0);
- NSTRACE (ns_draw_vertical_window_border);
+ NSTRACE ("ns_draw_vertical_window_border");
face = FACE_FROM_ID (f, VERTICAL_BORDER_FACE_ID);
if (face)
@@ -2545,7 +2714,7 @@ ns_draw_window_divider (struct window *w, int x0, int x1,
int y0, int y1)
struct face *face;
NSRect r = NSMakeRect (x0, y0, x1-x0, y1-y0);
- NSTRACE (ns_draw_window_divider);
+ NSTRACE ("ns_draw_window_divider");
face = FACE_FROM_ID (f, WINDOW_DIVIDER_FACE_ID);
if (face)
@@ -2802,7 +2971,7 @@ ns_draw_relief (NSRect r, int thickness, char raised_p,
NSColor *newBaseCol = nil;
NSRect sr = r;
- NSTRACE (ns_draw_relief);
+ NSTRACE ("ns_draw_relief");
/* set up colors */
@@ -2889,7 +3058,7 @@ ns_dumpglyphs_box_or_relief (struct glyph_string *s)
thickness = face->box_line_width;
- NSTRACE (ns_dumpglyphs_box_or_relief);
+ NSTRACE ("ns_dumpglyphs_box_or_relief");
last_x = ((s->row->full_width_p && !s->w->pseudo_window_p)
? WINDOW_RIGHT_EDGE_X (s->w)
@@ -2931,7 +3100,7 @@ ns_maybe_dumpglyphs_background (struct glyph_string *s,
char force_p)
certain cases. Others are left to the text rendering routine.
--------------------------------------------------------------------------
*/
{
- NSTRACE (ns_maybe_dumpglyphs_background);
+ NSTRACE ("ns_maybe_dumpglyphs_background");
if (!s->background_filled_p/* || s->hl == DRAW_MOUSE_FACE*/)
{
@@ -2994,7 +3163,7 @@ ns_dumpglyphs_image (struct glyph_string *s, NSRect r)
struct face *face;
NSColor *tdCol;
- NSTRACE (ns_dumpglyphs_image);
+ NSTRACE ("ns_dumpglyphs_image");
if (s->face->box != FACE_NO_BOX
&& s->first_glyph->left_box_line_p && s->slice.x == 0)
@@ -3311,7 +3480,7 @@ ns_draw_glyph_string (struct glyph_string *s)
struct font *font = s->face->font;
if (! font) font = FRAME_FONT (s->f);
- NSTRACE (ns_draw_glyph_string);
+ NSTRACE ("ns_draw_glyph_string");
if (s->next && s->right_overhang && !s->for_overlaps/*&&s->hl!=DRAW_CURSOR*/)
{
@@ -3469,7 +3638,7 @@ ns_send_appdefined (int value)
recognize and take as a command to halt the event loop.
--------------------------------------------------------------------------
*/
{
- /*NSTRACE (ns_send_appdefined); */
+ NSTRACE ("ns_send_appdefined");
#ifdef NS_IMPL_GNUSTEP
// GNUstep needs postEvent to happen on the main thread.
@@ -3643,7 +3812,7 @@ ns_read_socket (struct terminal *terminal, struct
input_event *hold_quit)
struct input_event ev;
int nevents;
-/* NSTRACE (ns_read_socket); */
+/* NSTRACE ("ns_read_socket"); */
#ifdef HAVE_NATIVE_FS
check_native_fs ();
@@ -3727,7 +3896,7 @@ ns_select (int nfds, fd_set *readfds, fd_set *writefds,
struct input_event event;
char c;
-/* NSTRACE (ns_select); */
+/* NSTRACE ("ns_select"); */
#ifdef HAVE_NATIVE_FS
check_native_fs ();
@@ -3903,7 +4072,7 @@ ns_set_vertical_scroll_bar (struct window *window,
}
}
- NSTRACE (ns_set_vertical_scroll_bar);
+ NSTRACE ("ns_set_vertical_scroll_bar");
/* Get dimensions. */
window_box (window, ANY_AREA, 0, &window_y, 0, &window_height);
@@ -3997,7 +4166,7 @@ ns_set_horizontal_scroll_bar (struct window *window,
}
}
- NSTRACE (ns_set_horizontal_scroll_bar);
+ NSTRACE ("ns_set_horizontal_scroll_bar");
/* Get dimensions. */
window_box (window, ANY_AREA, 0, &window_x, &window_width, 0);
@@ -4069,7 +4238,7 @@ ns_condemn_scroll_bars (struct frame *f)
id view;
NSArray *subviews = [[FRAME_NS_VIEW (f) superview] subviews];
- NSTRACE (ns_condemn_scroll_bars);
+ NSTRACE ("ns_condemn_scroll_bars");
for (i =[subviews count]-1; i >= 0; i--)
{
@@ -4088,7 +4257,7 @@ ns_redeem_scroll_bar (struct window *window)
--------------------------------------------------------------------------
*/
{
id bar;
- NSTRACE (ns_redeem_scroll_bar);
+ NSTRACE ("ns_redeem_scroll_bar");
if (!NILP (window->vertical_scroll_bar))
{
bar = XNS_SCROLL_BAR (window->vertical_scroll_bar);
@@ -4116,7 +4285,7 @@ ns_judge_scroll_bars (struct frame *f)
NSArray *subviews = [[eview superview] subviews];
BOOL removed = NO;
- NSTRACE (ns_judge_scroll_bars);
+ NSTRACE ("ns_judge_scroll_bars");
for (i = [subviews count]-1; i >= 0; --i)
{
view = [subviews objectAtIndex: i];
@@ -4294,6 +4463,8 @@ ns_delete_terminal (struct terminal *terminal)
{
struct ns_display_info *dpyinfo = terminal->display_info.ns;
+ NSTRACE ("ns_delete_terminal");
+
/* Protect against recursive calls. delete_frame in
delete_terminal calls us back when it deletes our last frame. */
if (!terminal->name)
@@ -4315,7 +4486,7 @@ ns_create_terminal (struct ns_display_info *dpyinfo)
{
struct terminal *terminal;
- NSTRACE (ns_create_terminal);
+ NSTRACE ("ns_create_terminal");
terminal = create_terminal (output_ns, &ns_redisplay_interface);
@@ -4361,7 +4532,9 @@ ns_term_init (Lisp_Object display_name)
if (ns_initialized) return x_display_list;
ns_initialized = 1;
- NSTRACE (ns_term_init);
+ block_input ();
+
+ NSTRACE ("ns_term_init");
[outerpool release];
outerpool = [[NSAutoreleasePool alloc] init];
@@ -4443,6 +4616,8 @@ ns_term_init (Lisp_Object display_name)
ns_antialias_threshold = NILP (tmp) ? 10.0 : XFLOATINT (tmp);
}
+ NSTRACE_MSG ("Colors");
+
{
NSColorList *cl = [NSColorList colorListNamed: @"Emacs"];
@@ -4476,6 +4651,8 @@ ns_term_init (Lisp_Object display_name)
}
}
+ NSTRACE_MSG ("Versions");
+
{
#ifdef NS_IMPL_GNUSTEP
Vwindow_system_version = build_string (gnustep_base_version);
@@ -4491,7 +4668,10 @@ ns_term_init (Lisp_Object display_name)
ns_app_name = [[NSProcessInfo processInfo] processName];
-/* Set up OS X app menu */
+ /* Set up OS X app menu */
+
+ NSTRACE_MSG ("Menu init");
+
#ifdef NS_IMPL_COCOA
{
NSMenu *appMenu;
@@ -4564,6 +4744,9 @@ ns_term_init (Lisp_Object display_name)
/* Register our external input/output types, used for determining
applicable services and also drag/drop eligibility. */
+
+ NSTRACE_MSG ("Input/output types");
+
ns_send_types = [[NSArray arrayWithObjects: NSStringPboardType, nil] retain];
ns_return_types = [[NSArray arrayWithObjects: NSStringPboardType, nil]
retain];
@@ -4577,6 +4760,8 @@ ns_term_init (Lisp_Object display_name)
right for fullscreen windows, so set this. */
[NSApp activateIgnoringOtherApps:YES];
+ NSTRACE_MSG ("Call NSApp run");
+
[NSApp run];
ns_do_open_file = YES;
@@ -4585,6 +4770,11 @@ ns_term_init (Lisp_Object display_name)
We must re-catch it so subprocess works. */
catch_child_signal ();
#endif
+
+ NSTRACE_MSG ("ns_term_init done");
+
+ unblock_input ();
+
return dpyinfo;
}
@@ -4620,6 +4810,8 @@ ns_term_shutdown (int sig)
- (id)init
{
+ NSTRACE ("[EmacsApp init]");
+
if ((self = [super init]))
{
#ifdef NS_IMPL_COCOA
@@ -4636,6 +4828,8 @@ ns_term_shutdown (int sig)
#ifdef NS_IMPL_COCOA
- (void)run
{
+ NSTRACE ("[EmacsApp run]");
+
#ifndef NSAppKitVersionNumber10_9
#define NSAppKitVersionNumber10_9 1265
#endif
@@ -4672,6 +4866,8 @@ ns_term_shutdown (int sig)
- (void)stop: (id)sender
{
+ NSTRACE ("[EmacsApp stop]");
+
shouldKeepRunning = NO;
// Stop possible dialog also. Noop if no dialog present.
// The file dialog still leaks 7k - 10k on 10.9 though.
@@ -4681,6 +4877,8 @@ ns_term_shutdown (int sig)
- (void)logNotification: (NSNotification *)notification
{
+ NSTRACE ("[EmacsApp logNotification]");
+
const char *name = [[notification name] UTF8String];
if (!strstr (name, "Update") && !strstr (name, "NSMenu")
&& !strstr (name, "WindowNumber"))
@@ -4697,7 +4895,7 @@ ns_term_shutdown (int sig)
int type = [theEvent type];
NSWindow *window = [theEvent window];
-/* NSTRACE (sendEvent); */
+ NSTRACE ("[EmacsApp sendEvent]");
/*fprintf (stderr, "received event of type %d\t%d\n", type);*/
#ifdef NS_IMPL_GNUSTEP
@@ -4804,6 +5002,8 @@ ns_term_shutdown (int sig)
- (void)newFrame: (id)sender
{
+ NSTRACE ("[EmacsApp newFrame]");
+
struct frame *emacsframe = SELECTED_FRAME ();
NSEvent *theEvent = [NSApp currentEvent];
@@ -4819,6 +5019,8 @@ ns_term_shutdown (int sig)
/* Open a file (used by below, after going into queue read by ns_read_socket)
*/
- (BOOL) openFile: (NSString *)fileName
{
+ NSTRACE ("[EmacsApp openFile]");
+
struct frame *emacsframe = SELECTED_FRAME ();
NSEvent *theEvent = [NSApp currentEvent];
@@ -4847,7 +5049,8 @@ ns_term_shutdown (int sig)
When application is loaded, terminate event loop in ns_term_init
--------------------------------------------------------------------------
*/
{
- NSTRACE (applicationDidFinishLaunching);
+ NSTRACE ("[EmacsApp applicationDidFinishLaunching]");
+
#ifdef NS_IMPL_GNUSTEP
((EmacsApp *)self)->applicationDidFinishLaunchingCalled = YES;
#endif
@@ -4896,6 +5099,8 @@ ns_term_shutdown (int sig)
- (void) terminate: (id)sender
{
+ NSTRACE ("[EmacsApp terminate]");
+
struct frame *emacsframe = SELECTED_FRAME ();
if (!emacs_event)
@@ -4932,6 +5137,8 @@ runAlertPanel(NSString *title,
- (NSApplicationTerminateReply)applicationShouldTerminate: (id)sender
{
+ NSTRACE ("[EmacsApp applicationShouldTerminate]");
+
bool ret;
if (NILP (ns_confirm_quit)) // || ns_shutdown_properly --> TO DO
@@ -5011,11 +5218,13 @@ not_in_argv (NSString *arg)
/* TODO: these may help w/IO switching btwn terminal and NSApp */
- (void)applicationWillBecomeActive: (NSNotification *)notification
{
+ NSTRACE ("[EmacsApp applicationWillBecomeActive]");
//ns_app_active=YES;
}
+
- (void)applicationDidBecomeActive: (NSNotification *)notification
{
- NSTRACE (applicationDidBecomeActive);
+ NSTRACE ("[EmacsApp applicationDidBecomeActive]");
#ifdef NS_IMPL_GNUSTEP
if (! applicationDidFinishLaunchingCalled)
@@ -5029,6 +5238,8 @@ not_in_argv (NSString *arg)
}
- (void)applicationDidResignActive: (NSNotification *)notification
{
+ NSTRACE ("[EmacsApp applicationDidResignActive]");
+
//ns_app_active=NO;
ns_send_appdefined (-1);
}
@@ -5047,7 +5258,7 @@ not_in_argv (NSString *arg)
The timeout specified to ns_select has passed.
--------------------------------------------------------------------------
*/
{
- /*NSTRACE (timeout_handler); */
+ /*NSTRACE ("timeout_handler"); */
ns_send_appdefined (-2);
}
@@ -5071,7 +5282,7 @@ not_in_argv (NSString *arg)
struct timespec timeout, *tmo;
NSAutoreleasePool *pool = nil;
- /* NSTRACE (fd_handler); */
+ /* NSTRACE ("fd_handler"); */
for (;;)
{
@@ -5208,7 +5419,7 @@ not_in_argv (NSString *arg)
- (void)dealloc
{
- NSTRACE (EmacsView_dealloc);
+ NSTRACE ("EmacsView_dealloc");
[toolbar release];
if (fs_state == FULLSCREEN_BOTH)
[nonfs_window release];
@@ -5226,7 +5437,7 @@ not_in_argv (NSString *arg)
CGFloat size;
NSFont *nsfont;
- NSTRACE (changeFont);
+ NSTRACE ("changeFont");
if (!emacs_event)
return;
@@ -5256,7 +5467,7 @@ not_in_argv (NSString *arg)
- (BOOL)acceptsFirstResponder
{
- NSTRACE (acceptsFirstResponder);
+ NSTRACE ("acceptsFirstResponder");
return YES;
}
@@ -5265,7 +5476,7 @@ not_in_argv (NSString *arg)
{
NSRect visible = [self visibleRect];
NSCursor *currentCursor = FRAME_POINTER_TYPE (emacsframe);
- NSTRACE (resetCursorRects);
+ NSTRACE ("resetCursorRects");
if (currentCursor == nil)
currentCursor = [NSCursor arrowCursor];
@@ -5290,7 +5501,7 @@ not_in_argv (NSString *arg)
int left_is_none;
unsigned int flags = [theEvent modifierFlags];
- NSTRACE (keyDown);
+ NSTRACE ("keyDown");
/* Rhapsody and OS X give up and down events for the arrow keys */
if (ns_fake_keydown == YES)
@@ -5753,7 +5964,7 @@ not_in_argv (NSString *arg)
struct ns_display_info *dpyinfo = FRAME_DISPLAY_INFO (emacsframe);
NSPoint p = [self convertPoint: [theEvent locationInWindow] fromView: nil];
- NSTRACE (mouseDown);
+ NSTRACE ("mouseDown");
[self deleteWorkingText];
@@ -5774,7 +5985,7 @@ not_in_argv (NSString *arg)
delta = [theEvent deltaX];
if (delta == 0)
{
- NSTRACE (deltaIsZero);
+ NSTRACE ("deltaIsZero");
return;
}
emacs_event->kind = HORIZ_WHEEL_EVENT;
@@ -5801,42 +6012,42 @@ not_in_argv (NSString *arg)
- (void)rightMouseDown: (NSEvent *)theEvent
{
- NSTRACE (rightMouseDown);
+ NSTRACE ("rightMouseDown");
[self mouseDown: theEvent];
}
- (void)otherMouseDown: (NSEvent *)theEvent
{
- NSTRACE (otherMouseDown);
+ NSTRACE ("otherMouseDown");
[self mouseDown: theEvent];
}
- (void)mouseUp: (NSEvent *)theEvent
{
- NSTRACE (mouseUp);
+ NSTRACE ("mouseUp");
[self mouseDown: theEvent];
}
- (void)rightMouseUp: (NSEvent *)theEvent
{
- NSTRACE (rightMouseUp);
+ NSTRACE ("rightMouseUp");
[self mouseDown: theEvent];
}
- (void)otherMouseUp: (NSEvent *)theEvent
{
- NSTRACE (otherMouseUp);
+ NSTRACE ("otherMouseUp");
[self mouseDown: theEvent];
}
- (void) scrollWheel: (NSEvent *)theEvent
{
- NSTRACE (scrollWheel);
+ NSTRACE ("scrollWheel");
[self mouseDown: theEvent];
}
@@ -5849,7 +6060,7 @@ not_in_argv (NSString *arg)
Lisp_Object frame;
NSPoint pt;
-// NSTRACE (mouseMoved);
+// NSTRACE ("mouseMoved");
dpyinfo->last_mouse_movement_time = EV_TIMESTAMP (e);
pt = [self convertPoint: [e locationInWindow] fromView: nil];
@@ -5869,7 +6080,7 @@ not_in_argv (NSString *arg)
if (!NILP (Vmouse_autoselect_window))
{
- NSTRACE (mouse_autoselect_window);
+ NSTRACE ("mouse_autoselect_window");
static Lisp_Object last_mouse_window;
Lisp_Object window
= window_from_coordinates (emacsframe, pt.x, pt.y, 0, 0);
@@ -5881,7 +6092,7 @@ not_in_argv (NSString *arg)
|| (EQ (XWINDOW (window)->frame,
XWINDOW (selected_window)->frame))))
{
- NSTRACE (in_window);
+ NSTRACE ("in_window");
emacs_event->kind = SELECT_WINDOW_EVENT;
emacs_event->frame_or_window = window;
EV_TRAILER2 (e);
@@ -5911,21 +6122,21 @@ not_in_argv (NSString *arg)
- (void)mouseDragged: (NSEvent *)e
{
- NSTRACE (mouseDragged);
+ NSTRACE ("mouseDragged");
[self mouseMoved: e];
}
- (void)rightMouseDragged: (NSEvent *)e
{
- NSTRACE (rightMouseDragged);
+ NSTRACE ("rightMouseDragged");
[self mouseMoved: e];
}
- (void)otherMouseDragged: (NSEvent *)e
{
- NSTRACE (otherMouseDragged);
+ NSTRACE ("otherMouseDragged");
[self mouseMoved: e];
}
@@ -5934,7 +6145,7 @@ not_in_argv (NSString *arg)
{
NSEvent *e =[[self window] currentEvent];
- NSTRACE (windowShouldClose);
+ NSTRACE ("windowShouldClose");
windowClosing = YES;
if (!emacs_event)
return NO;
@@ -5956,8 +6167,11 @@ not_in_argv (NSString *arg)
int oldh = FRAME_PIXEL_HEIGHT (emacsframe);
int neww, newh;
- NSTRACE (updateFrameSize);
+ NSTRACE ("updateFrameSize");
NSTRACE_SIZE ("Original size", NSMakeSize (oldw, oldh));
+ NSTRACE_RECT ("Original frame", wr);
+ NSTRACE_MSG ("Original columns: %d", cols);
+ NSTRACE_MSG ("Original rows: %d", rows);
if (! [self isFullscreen])
{
@@ -5974,13 +6188,19 @@ not_in_argv (NSString *arg)
if (wait_for_tool_bar)
{
if (FRAME_TOOLBAR_HEIGHT (emacsframe) == 0)
- return;
+ {
+ NSTRACE_MSG ("Waiting for toolbar");
+ return;
+ }
wait_for_tool_bar = NO;
}
neww = (int)wr.size.width - emacsframe->border_width;
newh = (int)wr.size.height - extra;
+ NSTRACE_SIZE ("New size", NSMakeSize (neww, newh));
+ NSTRACE_MSG ("tool_bar_height: %d", emacsframe->tool_bar_height);
+
cols = FRAME_PIXEL_WIDTH_TO_TEXT_COLS (emacsframe, neww);
rows = FRAME_PIXEL_HEIGHT_TO_TEXT_LINES (emacsframe, newh);
@@ -5990,11 +6210,13 @@ not_in_argv (NSString *arg)
if (rows < MINHEIGHT)
rows = MINHEIGHT;
+ NSTRACE_MSG ("New columns: %d", cols);
+ NSTRACE_MSG ("New rows: %d", rows);
+
if (oldr != rows || oldc != cols || neww != oldw || newh != oldh)
{
NSView *view = FRAME_NS_VIEW (emacsframe);
NSWindow *win = [view window];
- NSSize sz = [win resizeIncrements];
change_frame_size (emacsframe,
FRAME_PIXEL_TO_TEXT_WIDTH (emacsframe, neww),
@@ -6003,23 +6225,15 @@ not_in_argv (NSString *arg)
SET_FRAME_GARBAGED (emacsframe);
cancel_mouse_face (emacsframe);
- // Did resize increments change because of a font change?
- if (sz.width != FRAME_COLUMN_WIDTH (emacsframe) ||
- sz.height != FRAME_LINE_HEIGHT (emacsframe) ||
- (frame_resize_pixelwise && sz.width != 1))
- {
- sz.width = frame_resize_pixelwise
- ? 1 : FRAME_COLUMN_WIDTH (emacsframe);
- sz.height = frame_resize_pixelwise
- ? 1 : FRAME_LINE_HEIGHT (emacsframe);
- [win setResizeIncrements: sz];
-
- NSTRACE_SIZE ("New size", NSMakeSize (neww, newh));
- }
-
- [view setFrame: NSMakeRect (0, 0, neww, newh)];
+ wr = NSMakeRect (0, 0, neww, newh);
+ NSTRACE_RECT ("setFrame", wr);
+ [view setFrame: wr];
[self windowDidMove:nil]; // Update top/left.
}
+ else
+ {
+ NSTRACE_MSG ("No change");
+ }
}
- (NSSize)windowWillResize: (NSWindow *)sender toSize: (NSSize)frameSize
@@ -6027,9 +6241,10 @@ not_in_argv (NSString *arg)
{
int extra = 0;
- NSTRACE (windowWillResize);
- NSTRACE_SIZE ("Original size", frameSize);
-/*fprintf (stderr,"Window will resize: %.0f x
%.0f\n",frameSize.width,frameSize.height); */
+ NSTRACE ("windowWillResize: toSize: " NSTRACE_FMT_SIZE,
+ NSTRACE_ARG_SIZE (frameSize));
+ NSTRACE_RECT ("[sender frame]", [sender frame]);
+ NSTRACE_FSTYPE ("fs_state", fs_state);
if (fs_state == FULLSCREEN_MAXIMIZED
&& (maximized_width != (int)frameSize.width
@@ -6041,6 +6256,7 @@ not_in_argv (NSString *arg)
else if (fs_state == FULLSCREEN_HEIGHT
&& maximized_height != (int)frameSize.height)
[self setFSValue: FULLSCREEN_NONE];
+
if (fs_state == FULLSCREEN_NONE)
maximized_width = maximized_height = -1;
@@ -6090,7 +6306,33 @@ not_in_argv (NSString *arg)
}
}
#endif /* NS_IMPL_COCOA */
-/*fprintf (stderr," ...size became %.0f x %.0f (%d x
%d)\n",frameSize.width,frameSize.height,cols,rows); */
+
+ NSTRACE_MSG ("cols: %d rows: %d", cols, rows);
+
+ /* Restrict the new size to the text gird.
+
+ Don't restict the width if the user only adjusted the height, and
+ vice versa. (Without this, the frame would shrink, and move
+ slightly, if the window was resized by dragging one of its
+ borders.) */
+ if (!frame_resize_pixelwise)
+ {
+ NSRect r = [[self window] frame];
+
+ if (r.size.width != frameSize.width)
+ {
+ frameSize.width =
+ FRAME_TEXT_COLS_TO_PIXEL_WIDTH (emacsframe, cols);
+ }
+
+ if (r.size.height != frameSize.height)
+ {
+ frameSize.height =
+ FRAME_TEXT_LINES_TO_PIXEL_HEIGHT (emacsframe, rows) + extra;
+ }
+ }
+
+ NSTRACE_RETURN_SIZE (frameSize);
return frameSize;
}
@@ -6098,6 +6340,14 @@ not_in_argv (NSString *arg)
- (void)windowDidResize: (NSNotification *)notification
{
+ NSTRACE ("windowDidResize");
+
+ if (emacsframe->output_data.ns->in_animation)
+ {
+ NSTRACE_MSG ("Ignored (in animation)");
+ return;
+ }
+
if (! [self fsIsNative])
{
NSWindow *theWindow = [notification object];
@@ -6106,6 +6356,8 @@ not_in_argv (NSString *arg)
if ([self window] != theWindow) return;
}
+ NSTRACE_RECT ("frame", [[notification object] frame]);
+
#ifdef NS_IMPL_GNUSTEP
NSWindow *theWindow = [notification object];
@@ -6116,10 +6368,7 @@ not_in_argv (NSString *arg)
sz = [self windowWillResize: theWindow toSize: sz];
#endif /* NS_IMPL_GNUSTEP */
- NSTRACE (windowDidResize);
-/*fprintf (stderr,"windowDidResize: %.0f\n",[theWindow frame].size.height); */
-
-if (cols > 0 && rows > 0)
+ if (cols > 0 && rows > 0)
{
[self updateFrameSize: YES];
}
@@ -6148,7 +6397,7 @@ if (cols > 0 && rows > 0)
struct ns_display_info *dpyinfo = FRAME_DISPLAY_INFO (emacsframe);
struct frame *old_focus = dpyinfo->x_focus_frame;
- NSTRACE (windowDidBecomeKey);
+ NSTRACE ("windowDidBecomeKey");
if (emacsframe != old_focus)
dpyinfo->x_focus_frame = emacsframe;
@@ -6168,7 +6417,7 @@ if (cols > 0 && rows > 0)
{
struct ns_display_info *dpyinfo = FRAME_DISPLAY_INFO (emacsframe);
BOOL is_focus_frame = dpyinfo->x_focus_frame == emacsframe;
- NSTRACE (windowDidResignKey);
+ NSTRACE ("windowDidResignKey");
if (is_focus_frame)
dpyinfo->x_focus_frame = 0;
@@ -6203,7 +6452,7 @@ if (cols > 0 && rows > 0)
- (void)windowWillMiniaturize: sender
{
- NSTRACE (windowWillMiniaturize);
+ NSTRACE ("windowWillMiniaturize");
}
@@ -6224,11 +6473,10 @@ if (cols > 0 && rows > 0)
NSRect r, wr;
Lisp_Object tem;
NSWindow *win;
- NSSize sz;
NSColor *col;
NSString *name;
- NSTRACE (initFrameFromEmacs);
+ NSTRACE ("initFrameFromEmacs");
windowClosing = NO;
processingCompose = NO;
@@ -6283,9 +6531,6 @@ if (cols > 0 && rows > 0)
MAC_OS_X_VERSION_MAX_ALLOWED <= MAC_OS_X_VERSION_10_9
[win useOptimizedDrawing: YES];
#endif
- sz.width = frame_resize_pixelwise ? 1 : FRAME_COLUMN_WIDTH (f);
- sz.height = frame_resize_pixelwise ? 1 : FRAME_LINE_HEIGHT (f);
- [win setResizeIncrements: sz];
[[win contentView] addSubview: self];
@@ -6329,10 +6574,18 @@ if (cols > 0 && rows > 0)
NSScreen *screen = [win screen];
if (screen != 0)
- [win setFrameTopLeftPoint: NSMakePoint
- (IN_BOUND (-SCREENMAX, f->left_pos, SCREENMAX),
- IN_BOUND (-SCREENMAX,
- [screen frame].size.height - NS_TOP_POS (f), SCREENMAX))];
+ {
+ NSPoint pt = NSMakePoint
+ (IN_BOUND (-SCREENMAX, f->left_pos, SCREENMAX),
+ IN_BOUND (-SCREENMAX,
+ [screen frame].size.height - NS_TOP_POS (f), SCREENMAX));
+
+ NSTRACE_POINT ("setFrameTopLeftPoint", pt);
+
+ [win setFrameTopLeftPoint: pt];
+
+ NSTRACE_RECT ("new frame", [win frame]);
+ }
}
[win makeFirstResponder: self];
@@ -6362,7 +6615,7 @@ if (cols > 0 && rows > 0)
NSArray *screens = [NSScreen screens];
NSScreen *screen = [screens objectAtIndex: 0];
- NSTRACE (windowDidMove);
+ NSTRACE ("windowDidMove");
if (!emacsframe->output_data.ns)
return;
@@ -6380,6 +6633,10 @@ if (cols > 0 && rows > 0)
location so set_window_size moves the frame. */
- (BOOL)windowShouldZoom: (NSWindow *)sender toFrame: (NSRect)newFrame
{
+ NSTRACE (("[windowShouldZoom:win toFrame:" NSTRACE_FMT_RECT "]"
+ NSTRACE_FMT_RETURN "YES"),
+ NSTRACE_ARG_RECT (newFrame));
+
emacsframe->output_data.ns->zooming = 1;
return YES;
}
@@ -6391,71 +6648,124 @@ if (cols > 0 && rows > 0)
- (NSRect)windowWillUseStandardFrame:(NSWindow *)sender
defaultFrame:(NSRect)defaultFrame
{
+ // TODO: Rename to "currentFrame" and assign "result" properly in
+ // all paths.
NSRect result = [sender frame];
- NSTRACE (windowWillUseStandardFrame);
+ NSTRACE (("[windowWillUseStandardFrame: defaultFrame:"
+ NSTRACE_FMT_RECT "]"),
+ NSTRACE_ARG_RECT (defaultFrame));
+ NSTRACE_FSTYPE ("fs_state", fs_state);
+ NSTRACE_FSTYPE ("fs_before_fs", fs_before_fs);
+ NSTRACE_FSTYPE ("next_maximized", next_maximized);
+ NSTRACE_RECT ("ns_userRect", ns_userRect);
+ NSTRACE_RECT ("[sender frame]", [sender frame]);
if (fs_before_fs != -1) /* Entering fullscreen */
- {
- result = defaultFrame;
- }
- else if (next_maximized == FULLSCREEN_HEIGHT
- || (next_maximized == -1
- && abs ((int)(defaultFrame.size.height - result.size.height))
- > FRAME_LINE_HEIGHT (emacsframe)))
- {
- /* first click */
- ns_userRect = result;
- maximized_height = result.size.height = defaultFrame.size.height;
- maximized_width = -1;
- result.origin.y = defaultFrame.origin.y;
- [self setFSValue: FULLSCREEN_HEIGHT];
-#ifdef NS_IMPL_COCOA
- maximizing_resize = YES;
-#endif
- }
- else if (next_maximized == FULLSCREEN_WIDTH)
{
- ns_userRect = result;
- maximized_width = result.size.width = defaultFrame.size.width;
- maximized_height = -1;
- result.origin.x = defaultFrame.origin.x;
- [self setFSValue: FULLSCREEN_WIDTH];
+ NSTRACE_MSG ("Entering fullscreen");
+ result = defaultFrame;
}
- else if (next_maximized == FULLSCREEN_MAXIMIZED
- || (next_maximized == -1
- && abs ((int)(defaultFrame.size.width - result.size.width))
- > FRAME_COLUMN_WIDTH (emacsframe)))
+ else
{
- result = defaultFrame; /* second click */
- maximized_width = result.size.width;
- maximized_height = result.size.height;
- [self setFSValue: FULLSCREEN_MAXIMIZED];
+ // Save the window size and position (frame) before the resize.
+ if (fs_state != FULLSCREEN_MAXIMIZED
+ && fs_state != FULLSCREEN_WIDTH)
+ {
+ ns_userRect.size.width = result.size.width;
+ ns_userRect.origin.x = result.origin.x;
+ }
+
+ if (fs_state != FULLSCREEN_MAXIMIZED
+ && fs_state != FULLSCREEN_HEIGHT)
+ {
+ ns_userRect.size.height = result.size.height;
+ ns_userRect.origin.y = result.origin.y;
+ }
+
+ NSTRACE_RECT ("ns_userRect (2)", ns_userRect);
+
+ if (next_maximized == FULLSCREEN_HEIGHT
+ || (next_maximized == -1
+ && abs ((int)(defaultFrame.size.height - result.size.height))
+ > FRAME_LINE_HEIGHT (emacsframe)))
+ {
+ /* first click */
+ NSTRACE_MSG ("FULLSCREEN_HEIGHT");
+ maximized_height = result.size.height = defaultFrame.size.height;
+ maximized_width = -1;
+ result.origin.y = defaultFrame.origin.y;
+ if (ns_userRect.size.height != 0)
+ {
+ result.origin.x = ns_userRect.origin.x;
+ result.size.width = ns_userRect.size.width;
+ }
+ [self setFSValue: FULLSCREEN_HEIGHT];
#ifdef NS_IMPL_COCOA
- maximizing_resize = YES;
+ maximizing_resize = YES;
#endif
- }
- else
- {
- /* restore */
- result = ns_userRect.size.height ? ns_userRect : result;
- ns_userRect = NSMakeRect (0, 0, 0, 0);
+ }
+ else if (next_maximized == FULLSCREEN_WIDTH)
+ {
+ NSTRACE_MSG ("FULLSCREEN_WIDTH");
+ maximized_width = result.size.width = defaultFrame.size.width;
+ maximized_height = -1;
+ result.origin.x = defaultFrame.origin.x;
+ if (ns_userRect.size.width != 0)
+ {
+ result.origin.y = ns_userRect.origin.y;
+ result.size.height = ns_userRect.size.height;
+ }
+ [self setFSValue: FULLSCREEN_WIDTH];
+ }
+ else if (next_maximized == FULLSCREEN_MAXIMIZED
+ || (next_maximized == -1
+ && abs ((int)(defaultFrame.size.width - result.size.width))
+ > FRAME_COLUMN_WIDTH (emacsframe)))
+ {
+ NSTRACE_MSG ("FULLSCREEN_MAXIMIZED");
+
+ result = defaultFrame; /* second click */
+ maximized_width = result.size.width;
+ maximized_height = result.size.height;
+ [self setFSValue: FULLSCREEN_MAXIMIZED];
#ifdef NS_IMPL_COCOA
- maximizing_resize = fs_state != FULLSCREEN_NONE;
+ maximizing_resize = YES;
#endif
- [self setFSValue: FULLSCREEN_NONE];
- maximized_width = maximized_height = -1;
+ }
+ else
+ {
+ /* restore */
+ NSTRACE_MSG ("Restore");
+ result = ns_userRect.size.height ? ns_userRect : result;
+ NSTRACE_RECT ("restore (2)", result);
+ ns_userRect = NSMakeRect (0, 0, 0, 0);
+#ifdef NS_IMPL_COCOA
+ maximizing_resize = fs_state != FULLSCREEN_NONE;
+#endif
+ [self setFSValue: FULLSCREEN_NONE];
+ maximized_width = maximized_height = -1;
+ }
}
if (fs_before_fs == -1) next_maximized = -1;
+
+ NSTRACE_RECT ("Final ns_userRect", ns_userRect);
+ NSTRACE_MSG ("Final maximized_width: %d", maximized_width);
+ NSTRACE_MSG ("Final maximized_height: %d", maximized_height);
+ NSTRACE_FSTYPE ("Final next_maximized", next_maximized);
+
[self windowWillResize: sender toSize: result.size];
+
+ NSTRACE_RETURN_RECT (result);
+
return result;
}
- (void)windowDidDeminiaturize: sender
{
- NSTRACE (windowDidDeminiaturize);
+ NSTRACE ("windowDidDeminiaturize");
if (!emacsframe->output_data.ns)
return;
@@ -6473,7 +6783,7 @@ if (cols > 0 && rows > 0)
- (void)windowDidExpose: sender
{
- NSTRACE (windowDidExpose);
+ NSTRACE ("windowDidExpose");
if (!emacsframe->output_data.ns)
return;
@@ -6487,7 +6797,7 @@ if (cols > 0 && rows > 0)
- (void)windowDidMiniaturize: sender
{
- NSTRACE (windowDidMiniaturize);
+ NSTRACE ("windowDidMiniaturize");
if (!emacsframe->output_data.ns)
return;
@@ -6512,11 +6822,13 @@ if (cols > 0 && rows > 0)
- (void)windowWillEnterFullScreen:(NSNotification *)notification
{
+ NSTRACE ("windowWillEnterFullScreen");
fs_before_fs = fs_state;
}
- (void)windowDidEnterFullScreen:(NSNotification *)notification
{
+ NSTRACE ("windowDidEnterFullScreen");
[self setFSValue: FULLSCREEN_BOTH];
if (! [self fsIsNative])
{
@@ -6550,12 +6862,16 @@ if (cols > 0 && rows > 0)
- (void)windowWillExitFullScreen:(NSNotification *)notification
{
+ NSTRACE ("windowWillExitFullScreen");
+
if (next_maximized != -1)
fs_before_fs = next_maximized;
}
- (void)windowDidExitFullScreen:(NSNotification *)notification
{
+ NSTRACE ("windowDidExitFullScreen");
+
[self setFSValue: fs_before_fs];
fs_before_fs = -1;
#ifdef HAVE_NATIVE_FS
@@ -6613,10 +6929,11 @@ if (cols > 0 && rows > 0)
NSWindow *w, *fw;
BOOL onFirstScreen;
struct frame *f;
- NSSize sz;
NSRect r, wr;
NSColor *col;
+ NSTRACE ("toggleFullScreen");
+
if (fs_is_native)
{
#ifdef HAVE_NATIVE_FS
@@ -6633,9 +6950,6 @@ if (cols > 0 && rows > 0)
(FRAME_DEFAULT_FACE (f)),
f);
- sz.width = frame_resize_pixelwise ? 1 : FRAME_COLUMN_WIDTH (f);
- sz.height = frame_resize_pixelwise ? 1 : FRAME_LINE_HEIGHT (f);
-
if (fs_state != FULLSCREEN_BOTH)
{
NSScreen *screen = [w screen];
@@ -6675,7 +6989,6 @@ if (cols > 0 && rows > 0)
MAC_OS_X_VERSION_MAX_ALLOWED <= MAC_OS_X_VERSION_10_9
[fw useOptimizedDrawing: YES];
#endif
- [fw setResizeIncrements: sz];
[fw setBackgroundColor: col];
if ([col alphaComponent] != (EmacsCGFloat) 1.0)
[fw setOpaque: NO];
@@ -6712,7 +7025,6 @@ if (cols > 0 && rows > 0)
}
[w setContentView:[fw contentView]];
- [w setResizeIncrements: sz];
[w setBackgroundColor: col];
if ([col alphaComponent] != (EmacsCGFloat) 1.0)
[w setOpaque: NO];
@@ -6733,39 +7045,42 @@ if (cols > 0 && rows > 0)
- (void)handleFS
{
+ NSTRACE ("handleFS");
+
if (fs_state != emacsframe->want_fullscreen)
{
- NSSize sz;
- sz.width = frame_resize_pixelwise ? 1 : FRAME_COLUMN_WIDTH (emacsframe);
- sz.height = frame_resize_pixelwise ? 1 : FRAME_LINE_HEIGHT (emacsframe);
- [[self window] setResizeIncrements:sz];
-
if (fs_state == FULLSCREEN_BOTH)
{
+ NSTRACE_MSG ("fs_state == FULLSCREEN_BOTH");
[self toggleFullScreen:self];
}
switch (emacsframe->want_fullscreen)
{
case FULLSCREEN_BOTH:
+ NSTRACE_MSG ("FULLSCREEN_BOTH");
[self toggleFullScreen:self];
break;
case FULLSCREEN_WIDTH:
+ NSTRACE_MSG ("FULLSCREEN_WIDTH");
next_maximized = FULLSCREEN_WIDTH;
if (fs_state != FULLSCREEN_BOTH)
[[self window] performZoom:self];
break;
case FULLSCREEN_HEIGHT:
+ NSTRACE_MSG ("FULLSCREEN_HEIGHT");
next_maximized = FULLSCREEN_HEIGHT;
if (fs_state != FULLSCREEN_BOTH)
[[self window] performZoom:self];
break;
case FULLSCREEN_MAXIMIZED:
+ NSTRACE_MSG ("FULLSCREEN_MAXIMIZED");
next_maximized = FULLSCREEN_MAXIMIZED;
if (fs_state != FULLSCREEN_BOTH)
[[self window] performZoom:self];
break;
case FULLSCREEN_NONE:
+ NSTRACE_MSG ("FULLSCREEN_NONE");
if (fs_state != FULLSCREEN_BOTH)
{
next_maximized = FULLSCREEN_NONE;
@@ -6781,6 +7096,9 @@ if (cols > 0 && rows > 0)
- (void) setFSValue: (int)value
{
+ NSTRACE ("setFSValue");
+ NSTRACE_FSTYPE ("value", value);
+
Lisp_Object lval = Qnil;
switch (value)
{
@@ -6803,7 +7121,7 @@ if (cols > 0 && rows > 0)
- (void)mouseEntered: (NSEvent *)theEvent
{
- NSTRACE (mouseEntered);
+ NSTRACE ("mouseEntered");
if (emacsframe)
FRAME_DISPLAY_INFO (emacsframe)->last_mouse_movement_time
= EV_TIMESTAMP (theEvent);
@@ -6814,7 +7132,7 @@ if (cols > 0 && rows > 0)
{
Mouse_HLInfo *hlinfo = emacsframe ? MOUSE_HL_INFO (emacsframe) : NULL;
- NSTRACE (mouseExited);
+ NSTRACE ("mouseExited");
if (!hlinfo)
return;
@@ -6832,7 +7150,7 @@ if (cols > 0 && rows > 0)
- menuDown: sender
{
- NSTRACE (menuDown);
+ NSTRACE ("menuDown");
if (context_menu_value == -1)
context_menu_value = [sender tag];
else
@@ -6860,7 +7178,7 @@ if (cols > 0 && rows > 0)
NSEvent *theEvent;
int idx = [item tag] * TOOL_BAR_ITEM_NSLOTS;
- NSTRACE (toolbarClicked);
+ NSTRACE ("toolbarClicked");
if (!emacs_event)
return self;
@@ -6898,7 +7216,8 @@ if (cols > 0 && rows > 0)
int x = NSMinX (rect), y = NSMinY (rect);
int width = NSWidth (rect), height = NSHeight (rect);
- NSTRACE (drawRect);
+ NSTRACE ("drawRect");
+ NSTRACE_RECT ("input", rect);
if (!emacsframe || !emacsframe->output_data.ns)
return;
@@ -6924,7 +7243,7 @@ if (cols > 0 && rows > 0)
-(NSDragOperation) draggingEntered: (id <NSDraggingInfo>) sender
{
- NSTRACE (draggingEntered);
+ NSTRACE ("draggingEntered");
return NSDragOperationGeneric;
}
@@ -6945,7 +7264,7 @@ if (cols > 0 && rows > 0)
NSDragOperation op = [sender draggingSourceOperationMask];
int modifiers = 0;
- NSTRACE (performDragOperation);
+ NSTRACE ("performDragOperation");
if (!emacs_event)
return NO;
@@ -7045,7 +7364,7 @@ if (cols > 0 && rows > 0)
- (id) validRequestorForSendType: (NSString *)typeSent
returnType: (NSString *)typeReturned
{
- NSTRACE (validRequestorForSendType);
+ NSTRACE ("validRequestorForSendType");
if (typeSent != nil && [ns_send_types indexOfObject: typeSent] != NSNotFound
&& typeReturned == nil)
{
@@ -7107,7 +7426,7 @@ if (cols > 0 && rows > 0)
- setMiniwindowImage: (BOOL) setMini
{
id image = [[self window] miniwindowImage];
- NSTRACE (setMiniwindowImage);
+ NSTRACE ("setMiniwindowImage");
/* NOTE: under Cocoa miniwindowImage always returns nil, documentation
about "AppleDockIconEnabled" notwithstanding, however the set message
@@ -7126,10 +7445,16 @@ if (cols > 0 && rows > 0)
- (void) setRows: (int) r andColumns: (int) c
{
+ NSTRACE ("[EmacsView setRows:%d andColumns:%d]", r, c);
rows = r;
cols = c;
}
+- (int) fullscreenState
+{
+ return fs_state;
+}
+
@end /* EmacsView */
@@ -7199,73 +7524,133 @@ if (cols > 0 && rows > 0)
}
#endif /* NS_IMPL_COCOA */
-/* If we have multiple monitors, one above the other, we don't want to
- restrict the height to just one monitor. So we override this. */
-- (NSRect)constrainFrameRect:(NSRect)frameRect toScreen:(NSScreen *)screen
-{
- /* When making the frame visible for the first time or if there is just
- one screen, we want to constrain. Other times not. */
- NSArray *screens = [NSScreen screens];
- NSUInteger nr_screens = [screens count], nr_eff_screens = 0, i;
- NSTRACE (constrainFrameRect);
- NSTRACE_RECT ("input", frameRect);
+/* Constrain size and placement of a frame.
+
+ By returning the original "frameRect", the frame is not
+ contrained. This can lead to unwanted situations where, for
+ example, the menu bar covers the frame.
- if (ns_menu_bar_should_be_hidden ())
- return frameRect;
+ The default implementation (accessed using "super") constrains the
+ frame to the visible area of SCREEN, minus the menu bar (if
+ present) and the Dock. Note that default implementation also calls
+ windowWillResize, with the frame it thinks should have. (This can
+ make the frame exit maximized mode.)
- if (nr_screens == 1)
- return [super constrainFrameRect:frameRect toScreen:screen];
+ Note that this should work in situations where multiple monitors
+ are present. Common configurations are side-by-side monitors and a
+ monitor on top of another (e.g. when a laptop is placed under a
+ large screen). */
+- (NSRect)constrainFrameRect:(NSRect)frameRect toScreen:(NSScreen *)screen
+{
+ NSTRACE ("constrainFrameRect:" NSTRACE_FMT_RECT " toScreen:",
+ NSTRACE_ARG_RECT (frameRect));
#ifdef NS_IMPL_COCOA
#if MAC_OS_X_VERSION_MAX_ALLOWED >= MAC_OS_X_VERSION_10_9
// If separate spaces is on, it is like each screen is independent. There is
// no spanning of frames across screens.
if ([NSScreen screensHaveSeparateSpaces])
- return [super constrainFrameRect:frameRect toScreen:screen];
+ {
+ NSTRACE_MSG ("Screens have separate spaces");
+ frameRect = [super constrainFrameRect:frameRect toScreen:screen];
+ NSTRACE_RETURN_RECT (frameRect);
+ return frameRect;
+ }
#endif
#endif
- for (i = 0; i < nr_screens; ++i)
- {
- NSScreen *s = [screens objectAtIndex: i];
- NSRect scrrect = [s frame];
- NSRect intersect = NSIntersectionRect (frameRect, scrrect);
+ return constrain_frame_rect(frameRect);
+}
- if (intersect.size.width > 0 || intersect.size.height > 0)
- ++nr_eff_screens;
- }
- if (nr_eff_screens == 1)
- return [super constrainFrameRect:frameRect toScreen:screen];
+- (void)performZoom:(id)sender
+{
+ NSTRACE ("performZoom");
- /* The default implementation does two things 1) ensure that the top
- of the rectangle is below the menu bar (or below the top of the
- screen) and 2) resizes windows larger than the screen. As we
- don't want the latter, a smaller rectangle is used. */
-#define FAKE_HEIGHT 64
- float old_top = frameRect.origin.y + frameRect.size.height;
- NSRect r;
- r.size.height = FAKE_HEIGHT;
- r.size.width = frameRect.size.width;
- r.origin.x = frameRect.origin.x;
- r.origin.y = old_top - FAKE_HEIGHT;
+ return [super performZoom:sender];
+}
- NSTRACE_RECT ("input to super", r);
+- (void)zoom:(id)sender
+{
+ struct frame * f = SELECTED_FRAME ();
- r = [super constrainFrameRect:r toScreen:screen];
+ NSTRACE ("zoom");
- NSTRACE_RECT ("output from super", r);
+ ns_update_auto_hide_menu_bar();
- float new_top = r.origin.y + FAKE_HEIGHT;
- if (new_top < old_top)
- {
- frameRect.origin.y = new_top - frameRect.size.height;
- }
+ // Below are three zoom implementations. In the final commit, the
+ // idea is that the last should be included.
+
+#if 0
+ // Native zoom done using the standard zoom animation. Size of the
+ // resulting frame reduced to accomodate the Dock and, if present,
+ // the menu-bar.
+ [super zoom:sender];
+
+#elsif 0
+ // Native zoom done using the standard zoom animation, plus an
+ // explicit resize to cover the full screen.
+ [super zoom:sender];
+
+ // After the native zoom, resize the resulting frame to fill the
+ // entire screen, except the menu-bar.
+ //
+ // This works for all practical purposes. (The only minor oddity is
+ // when transiting from full-height frame to a maximized, the
+ // animation reduces the height of the frame slighty (to the 4
+ // pixels needed to accomodate the Doc) before it snaps back into
+ // full height. The user would need a very trained eye to spot
+ // this.)
+ NSScreen * screen = [self screen];
+ if (screen != nil)
+ {
+ int fs_state = [(EmacsView *)[self delegate] fullscreenState];
- NSTRACE_RECT ("output", frameRect);
+ NSTRACE_FSTYPE ("fullscreenState", fs_state);
- return frameRect;
-#undef FAKE_HEIGHT
+ NSRect sr = [screen frame];
+ NSRect wr = [self frame];
+ NSTRACE_RECT ("Rect after zoom", wr);
+
+ NSRect newWr = wr;
+
+ if (fs_state == FULLSCREEN_MAXIMIZED
+ || fs_state == FULLSCREEN_HEIGHT)
+ {
+ newWr.origin.x = 0;
+ newWr.size.height = sr.size.height - ns_menu_bar_height(screen);
+ }
+
+ if (fs_state == FULLSCREEN_MAXIMIZED
+ || fs_state == FULLSCREEN_WIDTH)
+ {
+ newWr.origin.y = 0;
+ newWr.size.width = sr.size.width;
+ }
+
+ if (newWr.size.width != wr.size.width
+ || newWr.size.height != wr.size.height
+ || newWr.origin.x != wr.origin.x
+ || newWr.origin.y != wr.origin.y)
+ {
+ NSTRACE_RECT ("Corrected rect", newWr);
+ [self setFrame: newWr display: NO];
+ }
+ }
+#else
+ // Non-native zoom which is done instantaneous. The resulting frame
+ // covert the entire scrren, except the menu-bar, if present.
+ NSScreen * screen = [self screen];
+ if (screen != nil)
+ {
+ NSRect sr = [screen frame];
+ sr.size.height -= ns_menu_bar_height (screen);
+
+ sr = [[self delegate] windowWillUseStandardFrame:self
+ defaultFrame:sr];
+ [self setFrame: sr display: NO];
+ }
+#endif
}
@end /* EmacsWindow */
@@ -7316,7 +7701,7 @@ if (cols > 0 && rows > 0)
- initFrame: (NSRect )r window: (Lisp_Object)nwin
{
- NSTRACE (EmacsScroller_initFrame);
+ NSTRACE ("EmacsScroller_initFrame");
r.size.width = [EmacsScroller scrollerWidth];
[super initWithFrame: r/*NSMakeRect (0, 0, 0, 0)*/];
@@ -7362,7 +7747,7 @@ if (cols > 0 && rows > 0)
- (void)setFrame: (NSRect)newRect
{
- NSTRACE (EmacsScroller_setFrame);
+ NSTRACE ("EmacsScroller_setFrame");
/* block_input (); */
pixel_height = NSHeight (newRect);
if (pixel_height == 0) pixel_height = 1;
@@ -7374,7 +7759,7 @@ if (cols > 0 && rows > 0)
- (void)dealloc
{
- NSTRACE (EmacsScroller_dealloc);
+ NSTRACE ("EmacsScroller_dealloc");
if (window)
wset_vertical_scroll_bar (window, Qnil);
window = 0;
@@ -7384,7 +7769,7 @@ if (cols > 0 && rows > 0)
- condemn
{
- NSTRACE (condemn);
+ NSTRACE ("condemn");
condemned =YES;
return self;
}
@@ -7392,7 +7777,7 @@ if (cols > 0 && rows > 0)
- reprieve
{
- NSTRACE (reprieve);
+ NSTRACE ("reprieve");
condemned =NO;
return self;
}
@@ -7400,7 +7785,7 @@ if (cols > 0 && rows > 0)
-(bool)judge
{
- NSTRACE (judge);
+ NSTRACE ("judge");
bool ret = condemned;
if (condemned)
{
@@ -7424,7 +7809,7 @@ if (cols > 0 && rows > 0)
- (void)resetCursorRects
{
NSRect visible = [self visibleRect];
- NSTRACE (resetCursorRects);
+ NSTRACE ("resetCursorRects");
if (!NSIsEmptyRect (visible))
[self addCursorRect: visible cursor: [NSCursor arrowCursor]];
@@ -7442,7 +7827,7 @@ if (cols > 0 && rows > 0)
- setPosition: (int)position portion: (int)portion whole: (int)whole
{
- NSTRACE (setPosition);
+ NSTRACE ("setPosition");
em_position = position;
em_portion = portion;
@@ -7547,7 +7932,7 @@ if (cols > 0 && rows > 0)
CGFloat inc = 0.0, loc, kloc, pos;
int edge = 0;
- NSTRACE (EmacsScroller_mouseDown);
+ NSTRACE ("EmacsScroller_mouseDown");
switch (part)
{
@@ -7644,7 +8029,7 @@ if (cols > 0 && rows > 0)
NSRect sr;
double loc, pos;
- NSTRACE (EmacsScroller_mouseDragged);
+ NSTRACE ("EmacsScroller_mouseDragged");
sr = [self convertRect: [self rectForPart: NSScrollerKnobSlot]
toView: nil];
@@ -7813,7 +8198,7 @@ ns_xlfd_to_fontname (const char *xlfd)
void
syms_of_nsterm (void)
{
- NSTRACE (syms_of_nsterm);
+ NSTRACE ("syms_of_nsterm");
ns_antialias_threshold = 10.0;
diff --git a/src/process.c b/src/process.c
index dc93b86..ed1d59d 100644
--- a/src/process.c
+++ b/src/process.c
@@ -7176,8 +7176,10 @@ setup_process_coding_systems (Lisp_Object process)
}
DEFUN ("get-buffer-process", Fget_buffer_process, Sget_buffer_process, 1, 1, 0,
- doc: /* Return the (or a) process associated with BUFFER.
-BUFFER may be a buffer or the name of one. */)
+ doc: /* Return the (or a) live process associated with BUFFER.
+BUFFER may be a buffer or the name of one.
+Return nil if all processes associated with BUFFER have been
+deleted or killed. */)
(register Lisp_Object buffer)
{
#ifdef subprocesses
diff --git a/src/w32notify.c b/src/w32notify.c
index e822d95..de27ab8 100644
--- a/src/w32notify.c
+++ b/src/w32notify.c
@@ -525,7 +525,7 @@ generate notifications correctly, though. */)
/* The underlying features are available only since XP. */
if (os_subtype == OS_9X
- || (w32_major_version == 5 && w32_major_version < 1))
+ || (w32_major_version == 5 && w32_minor_version < 1))
{
errno = ENOSYS;
report_file_notify_error ("Watching filesystem events is not supported",
diff --git a/src/window.c b/src/window.c
index d5bb210..43517ab 100644
--- a/src/window.c
+++ b/src/window.c
@@ -208,6 +208,20 @@ wset_combination (struct window *w, bool horflag,
Lisp_Object val)
w->horizontal = horflag;
}
+static void
+wset_update_mode_line (struct window *w)
+{
+ /* If this window is the selected window on its frame, set the
+ global variable update_mode_lines, so that x_consider_frame_title
+ will consider this frame's title for rtedisplay. */
+ Lisp_Object fselected_window = XFRAME (WINDOW_FRAME (w))->selected_window;
+
+ if (WINDOWP (fselected_window) && XWINDOW (fselected_window) == w)
+ update_mode_lines = 42;
+ else
+ w->update_mode_line = true;
+}
+
/* True if leaf window W doesn't reflect the actual state
of displayed buffer due to its text or overlays change. */
@@ -1669,7 +1683,7 @@ overriding motion of point in order to display at this
exact start. */)
w->start_at_line_beg = false;
if (NILP (noforce))
w->force_start = true;
- w->update_mode_line = true;
+ wset_update_mode_line (w);
/* Bug#15957. */
w->window_end_valid = false;
wset_redisplay (w);
@@ -3274,7 +3288,8 @@ set_window_buffer (Lisp_Object window, Lisp_Object buffer,
/* Maybe we could move this into the `if' but it's not obviously safe and
I doubt it's worth the trouble. */
wset_redisplay (w);
- w->update_mode_line = true;
+
+ wset_update_mode_line (w);
/* We must select BUFFER to run the window-scroll-functions and to look up
the buffer-local value of Vwindow_point_insertion_type. */
@@ -4828,7 +4843,7 @@ window_scroll_pixel_based (Lisp_Object window, int n,
bool whole, bool noerror)
set_marker_restricted (w->start, make_number (spos),
w->contents);
w->start_at_line_beg = true;
- w->update_mode_line = true;
+ wset_update_mode_line (w);
/* Set force_start so that redisplay_window will run the
window-scroll-functions. */
w->force_start = true;
@@ -4976,7 +4991,7 @@ window_scroll_pixel_based (Lisp_Object window, int n,
bool whole, bool noerror)
IT_BYTEPOS (it));
bytepos = marker_byte_position (w->start);
w->start_at_line_beg = (pos == BEGV || FETCH_BYTE (bytepos - 1) == '\n');
- w->update_mode_line = true;
+ wset_update_mode_line (w);
/* Set force_start so that redisplay_window will run the
window-scroll-functions. */
w->force_start = true;
@@ -5210,7 +5225,7 @@ window_scroll_line_based (Lisp_Object window, int n, bool
whole, bool noerror)
set_marker_restricted_both (w->start, w->contents, pos, pos_byte);
w->start_at_line_beg = !NILP (bolp);
- w->update_mode_line = true;
+ wset_update_mode_line (w);
/* Set force_start so that redisplay_window will run
the window-scroll-functions. */
w->force_start = true;
diff --git a/src/xdisp.c b/src/xdisp.c
index 976774b..0923dfa 100644
--- a/src/xdisp.c
+++ b/src/xdisp.c
@@ -456,7 +456,7 @@ static bool message_enable_multibyte;
OTOH if it's non-zero we wil have to loop through all windows and then check
the `redisplay' bit of the corresponding window, frame, and buffer, in order
- to decide whether that window needs attention or not. Not that we can't
+ to decide whether that window needs attention or not. Note that we can't
just look at the frame's redisplay bit to decide that the whole frame can be
skipped, since even if the frame's redisplay bit is unset, some of its
windows's redisplay bits may be set.
@@ -476,6 +476,10 @@ int windows_or_buffers_changed;
For any other value, redisplay all mode lines (the number used is then only
used to track down the cause for this full-redisplay).
+ Since the frame title uses the same %-constructs as the mode line
+ (except %c and %l), if this variable is non-zero, we also consider
+ redisplaying the title of each frame, see x_consider_frame_title.
+
The `redisplay' bits are the same as those used for
windows_or_buffers_changed, and setting windows_or_buffers_changed also
causes recomputation of the mode lines of all those windows. IOW this
@@ -13976,7 +13980,19 @@ redisplay_internal (void)
above caused some change (e.g., a change in faces) that requires
considering the entire frame again. */
if (sf->fonts_changed || sf->redisplay)
- goto retry;
+ {
+ if (sf->redisplay)
+ {
+ /* Set this to force a more thorough redisplay.
+ Otherwise, we might immediately loop back to the
+ above "else-if" clause (since all the conditions that
+ led here might still be true), and we will then
+ infloop, because the selected-frame's redisplay flag
+ is not (and cannot be) reset. */
+ windows_or_buffers_changed = 50;
+ }
+ goto retry;
+ }
/* Prevent freeing of realized faces, since desired matrices are
pending that reference the faces we computed and cached. */
@@ -16889,7 +16905,8 @@ redisplay_window (Lisp_Object window, bool
just_this_one_p)
finish_menu_bars:
- /* When we reach a frame's selected window, redo the frame's menu bar. */
+ /* When we reach a frame's selected window, redo the frame's menu
+ bar and the frame's title. */
if (update_mode_line
&& EQ (FRAME_SELECTED_WINDOW (f), window))
{
@@ -16924,6 +16941,7 @@ redisplay_window (Lisp_Object window, bool
just_this_one_p)
ignore_mouse_drag_p = true;
#endif
}
+ x_consider_frame_title (w->frame);
#endif
}
diff --git a/test/automated/auto-revert-tests.el
b/test/automated/auto-revert-tests.el
index 86184d6..7cabc5c 100644
--- a/test/automated/auto-revert-tests.el
+++ b/test/automated/auto-revert-tests.el
@@ -136,8 +136,6 @@
buf)
(unwind-protect
(progn
- (with-current-buffer (get-buffer-create "*Messages*")
- (narrow-to-region (point-max) (point-max)))
(setq buf (dired-noselect temporary-file-directory))
(with-current-buffer buf
;; `buffer-stale--default-function' checks for
@@ -151,6 +149,8 @@
;; Delete file. We wait for a second, in order to have
;; another timestamp.
+ (with-current-buffer (get-buffer-create "*Messages*")
+ (narrow-to-region (point-max) (point-max)))
(sleep-for 1)
(delete-file tmpfile)
diff --git a/test/automated/file-notify-tests.el
b/test/automated/file-notify-tests.el
index 1763648..222bdc5 100644
--- a/test/automated/file-notify-tests.el
+++ b/test/automated/file-notify-tests.el
@@ -61,9 +61,11 @@
(defvar file-notify--test-results nil)
(defvar file-notify--test-event nil)
(defvar file-notify--test-events nil)
+(defvar file-notify--test-expected-events nil)
+
(defun file-notify--test-timeout ()
"Timeout to wait for arriving events, in seconds."
- (if (file-remote-p temporary-file-directory) 10 3))
+ (if (file-remote-p temporary-file-directory) 6 3))
(defun file-notify--test-cleanup ()
"Cleanup after a test."
@@ -71,23 +73,24 @@
(when (and file-notify--test-tmpfile
(file-exists-p file-notify--test-tmpfile))
- (if (directory-name-p file-notify--test-tmpfile)
+ (if (file-directory-p file-notify--test-tmpfile)
(delete-directory file-notify--test-tmpfile 'recursive)
(delete-file file-notify--test-tmpfile)))
(when (and file-notify--test-tmpfile1
(file-exists-p file-notify--test-tmpfile1))
- (if (directory-name-p file-notify--test-tmpfile1)
+ (if (file-directory-p file-notify--test-tmpfile1)
(delete-directory file-notify--test-tmpfile1 'recursive)
(delete-file file-notify--test-tmpfile1)))
(when (file-remote-p temporary-file-directory)
(tramp-cleanup-connection
(tramp-dissect-file-name temporary-file-directory) nil 'keep-password))
- (setq file-notify--test-tmpfile nil)
- (setq file-notify--test-tmpfile1 nil)
- (setq file-notify--test-desc nil)
- (setq file-notify--test-results nil)
- (setq file-notify--test-events nil)
+ (setq file-notify--test-tmpfile nil
+ file-notify--test-tmpfile1 nil
+ file-notify--test-desc nil
+ file-notify--test-results nil
+ file-notify--test-events nil
+ file-notify--test-expected-events nil)
(when file-notify--test-event
(error "file-notify--test-event should not be set but bound dynamically")))
@@ -166,6 +169,11 @@ being the result.")
(ert-deftest file-notify-test01-add-watch ()
"Check `file-notify-add-watch'."
(skip-unless (file-notify--test-local-enabled))
+
+ (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)
+ file-notify--test-tmpfile1
+ (format "%s/%s" file-notify--test-tmpfile (md5 (current-time-string))))
+
;; Check, that different valid parameters are accepted.
(should
(setq file-notify--test-desc
@@ -181,6 +189,12 @@ being the result.")
(file-notify-add-watch
temporary-file-directory '(change attribute-change) 'ignore)))
(file-notify-rm-watch file-notify--test-desc)
+ ;; The file does not need to exist, just the upper directory.
+ (should
+ (setq file-notify--test-desc
+ (file-notify-add-watch
+ file-notify--test-tmpfile '(change attribute-change) 'ignore)))
+ (file-notify-rm-watch file-notify--test-desc)
;; Check error handling.
(should-error (file-notify-add-watch 1 2 3 4)
@@ -197,6 +211,13 @@ being the result.")
(equal (should-error
(file-notify-add-watch temporary-file-directory '(change) 3))
'(wrong-type-argument 3)))
+ ;; The upper directory of a file must exist.
+ (should
+ (equal (should-error
+ (file-notify-add-watch
+ file-notify--test-tmpfile1 '(change attribute-change) 'ignore))
+ `(file-notify-error
+ "Directory does not exist" ,file-notify--test-tmpfile)))
;; Cleanup.
(file-notify--test-cleanup))
@@ -208,13 +229,16 @@ being the result.")
"Ert test function to be called by `file-notify--test-event-handler'.
We cannot pass arguments, so we assume that `file-notify--test-event'
is bound somewhere."
- ;;(message "Event %S" file-notify--test-event)
;; Check the descriptor.
(should (equal (car file-notify--test-event) file-notify--test-desc))
;; Check the file name.
(should
- (string-equal (file-notify--event-file-name file-notify--test-event)
- file-notify--test-tmpfile))
+ (or (string-equal (file-notify--event-file-name file-notify--test-event)
+ file-notify--test-tmpfile)
+ (string-equal (directory-file-name
+ (file-name-directory
+ (file-notify--event-file-name file-notify--test-event)))
+ file-notify--test-tmpfile)))
;; Check the second file name if exists.
(when (eq (nth 1 file-notify--test-event) 'renamed)
(should
@@ -229,10 +253,15 @@ and the event to `file-notify--test-events'."
(let* ((file-notify--test-event event)
(result
(ert-run-test (make-ert-test :body 'file-notify--test-event-test))))
- (setq file-notify--test-events
- (append file-notify--test-events `(,file-notify--test-event)))
- (setq file-notify--test-results
- (append file-notify--test-results `(,result)))))
+ ;; Do not add temporary files, this would confuse the checks.
+ (unless (string-match
+ (regexp-quote ".#")
+ (file-notify--event-file-name file-notify--test-event))
+ ;;(message "file-notify--test-event-handler %S" file-notify--test-event)
+ (setq file-notify--test-events
+ (append file-notify--test-events `(,file-notify--test-event))
+ file-notify--test-results
+ (append file-notify--test-results `(,result))))))
(defun file-notify--test-make-temp-name ()
"Create a temporary file name for test."
@@ -252,6 +281,8 @@ Don't wait longer than TIMEOUT seconds for the events to be
delivered."
(declare (indent 2))
(let ((outer (make-symbol "outer")))
`(let ((,outer file-notify--test-events))
+ (setq file-notify--test-expected-events
+ (append file-notify--test-expected-events ,events))
(let (file-notify--test-events)
,@body
(file-notify--wait-for-events
@@ -263,12 +294,14 @@ Don't wait longer than TIMEOUT seconds for the events to
be delivered."
(ert-deftest file-notify-test02-events ()
"Check file creation/change/removal notifications."
(skip-unless (file-notify--test-local-enabled))
+
+ (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)
+ file-notify--test-tmpfile1 (file-notify--test-make-temp-name))
+
(unwind-protect
(progn
- ;; Check creation, change, and deletion.
- (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)
- file-notify--test-tmpfile1 (file-notify--test-make-temp-name)
- file-notify--test-desc
+ ;; Check creation, change and deletion.
+ (setq file-notify--test-desc
(file-notify-add-watch
file-notify--test-tmpfile
'(change) 'file-notify--test-event-handler))
@@ -277,7 +310,31 @@ Don't wait longer than TIMEOUT seconds for the events to
be delivered."
(write-region
"any text" nil file-notify--test-tmpfile nil 'no-message)
(delete-file file-notify--test-tmpfile))
- (file-notify-rm-watch file-notify--test-desc)
+ ;; `file-notify-rm-watch' fires the `stopped' event. Suppress it.
+ (let (file-notify--test-events)
+ (file-notify-rm-watch file-notify--test-desc))
+
+ ;; Check creation, change and deletion. There must be a
+ ;; `stopped' event when deleting the directory. It doesn't
+ ;; work for w32notify.
+ (unless (eq file-notify--library 'w32notify)
+ (make-directory file-notify--test-tmpfile)
+ (setq file-notify--test-desc
+ (file-notify-add-watch
+ file-notify--test-tmpfile
+ '(change) 'file-notify--test-event-handler))
+ (file-notify--test-with-events
+ (file-notify--test-timeout)
+ ;; There are two `deleted' events, for the file and for
+ ;; the directory.
+ '(created changed deleted deleted stopped)
+ (write-region
+ "any text" nil (expand-file-name "foo" file-notify--test-tmpfile)
+ nil 'no-message)
+ (delete-directory file-notify--test-tmpfile 'recursive))
+ ;; `file-notify-rm-watch' fires the `stopped' event. Suppress it.
+ (let (file-notify--test-events)
+ (file-notify-rm-watch file-notify--test-desc)))
;; Check copy.
(setq file-notify--test-desc
@@ -301,7 +358,9 @@ Don't wait longer than TIMEOUT seconds for the events to be
delivered."
(set-file-times file-notify--test-tmpfile '(0 0))
(delete-file file-notify--test-tmpfile)
(delete-file file-notify--test-tmpfile1))
- (file-notify-rm-watch file-notify--test-desc)
+ ;; `file-notify-rm-watch' fires the `stopped' event. Suppress it.
+ (let (file-notify--test-events)
+ (file-notify-rm-watch file-notify--test-desc))
;; Check rename.
(setq file-notify--test-desc
@@ -316,7 +375,9 @@ Don't wait longer than TIMEOUT seconds for the events to be
delivered."
(rename-file file-notify--test-tmpfile file-notify--test-tmpfile1)
;; After the rename, we won't get events anymore.
(delete-file file-notify--test-tmpfile1))
- (file-notify-rm-watch file-notify--test-desc)
+ ;; `file-notify-rm-watch' fires the `stopped' event. Suppress it.
+ (let (file-notify--test-events)
+ (file-notify-rm-watch file-notify--test-desc))
;; Check attribute change. It doesn't work for w32notify.
(unless (eq file-notify--library 'w32notify)
@@ -325,41 +386,32 @@ Don't wait longer than TIMEOUT seconds for the events to
be delivered."
file-notify--test-tmpfile
'(attribute-change) 'file-notify--test-event-handler))
(file-notify--test-with-events
- (file-notify--test-timeout) '(attribute-changed)
- (write-region
- "any text" nil file-notify--test-tmpfile nil 'no-message)
- (set-file-modes file-notify--test-tmpfile 000)
- (delete-file file-notify--test-tmpfile))
- (file-notify-rm-watch file-notify--test-desc)
-
- ;; With gfilenotify, there are timing issues with attribute
- ;; changes in a short time period. So we apply 2 tests.
- (setq file-notify--test-desc
- (file-notify-add-watch
- file-notify--test-tmpfile
- '(attribute-change) 'file-notify--test-event-handler))
- (file-notify--test-with-events
- (file-notify--test-timeout) '(attribute-changed)
+ (file-notify--test-timeout)
+ (if (file-remote-p temporary-file-directory)
+ ;; In the remote case, `write-region' raises also an
+ ;; `attribute-changed' event.
+ '(attribute-changed attribute-changed attribute-changed)
+ '(attribute-changed attribute-changed))
+ ;; We must use short delays between the operations.
+ ;; Otherwise, not all events arrive us in the remote case.
(write-region
"any text" nil file-notify--test-tmpfile nil 'no-message)
+ (read-event nil nil 0.1)
(set-file-modes file-notify--test-tmpfile 000)
+ (read-event nil nil 0.1)
+ (set-file-times file-notify--test-tmpfile '(0 0))
+ (read-event nil nil 0.1)
(delete-file file-notify--test-tmpfile))
- (file-notify-rm-watch file-notify--test-desc))
+ ;; `file-notify-rm-watch' fires the `stopped' event. Suppress it.
+ (let (file-notify--test-events)
+ (file-notify-rm-watch file-notify--test-desc)))
;; Check the global sequence again just to make sure that
;; `file-notify--test-events' has been set correctly.
(should (equal (mapcar #'cadr file-notify--test-events)
- (if (eq file-notify--library 'w32notify)
- '(created changed deleted
- created changed changed deleted
- created changed renamed)
- '(created changed deleted
- created changed deleted
- created changed renamed
- attribute-changed attribute-changed))))
+ file-notify--test-expected-events))
(should file-notify--test-results)
(dolist (result file-notify--test-results)
- ;;(message "%s" (ert-test-result-messages result))
(when (ert-test-failed-p result)
(ert-fail
(cadr (ert-test-result-with-condition-condition result))))))
@@ -407,8 +459,10 @@ Don't wait longer than TIMEOUT seconds for the events to
be delivered."
(should auto-revert-use-notify)
(should auto-revert-notify-watch-descriptor)
- ;; Modify file. We wait for a second, in order to
- ;; have another timestamp.
+ ;; Modify file. We wait for a second, in order to have
+ ;; another timestamp.
+ (with-current-buffer (get-buffer-create "*Messages*")
+ (narrow-to-region (point-max) (point-max)))
(sleep-for 1)
(write-region
"another text" nil file-notify--test-tmpfile nil 'no-message)
@@ -420,9 +474,34 @@ Don't wait longer than TIMEOUT seconds for the events to
be delivered."
(string-match
(format-message "Reverting buffer `%s'." (buffer-name buf))
(buffer-string))))
- (should (string-match "another text" (buffer-string)))))
+ (should (string-match "another text" (buffer-string)))
+
+ ;; Stop file notification. Autorevert shall still work via
polling.
+ (file-notify-rm-watch auto-revert-notify-watch-descriptor)
+ (file-notify--wait-for-events
+ timeout (null auto-revert-use-notify))
+ (should-not auto-revert-use-notify)
+ (should-not auto-revert-notify-watch-descriptor)
+
+ ;; Modify file. We wait for two seconds, in order to have
+ ;; another timestamp. One second seems to be too short.
+ (with-current-buffer (get-buffer-create "*Messages*")
+ (narrow-to-region (point-max) (point-max)))
+ (sleep-for 2)
+ (write-region
+ "foo bla" nil file-notify--test-tmpfile nil 'no-message)
+
+ ;; Check, that the buffer has been reverted.
+ (with-current-buffer (get-buffer-create "*Messages*")
+ (file-notify--wait-for-events
+ timeout
+ (string-match
+ (format-message "Reverting buffer `%s'." (buffer-name buf))
+ (buffer-string))))
+ (should (string-match "foo bla" (buffer-string)))))
;; Cleanup.
+ (with-current-buffer "*Messages*" (widen))
(ignore-errors (kill-buffer buf))
(file-notify--test-cleanup))))
@@ -435,18 +514,20 @@ Don't wait longer than TIMEOUT seconds for the events to
be delivered."
(unwind-protect
(progn
- (setq file-notify--test-tmpfile (file-notify--test-make-temp-name))
- (setq file-notify--test-desc
+ (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)
+ file-notify--test-desc
(file-notify-add-watch
file-notify--test-tmpfile
'(change) #'file-notify--test-event-handler))
(file-notify--test-with-events
- (file-notify--test-timeout) '(created changed)
+ (file-notify--test-timeout) '(created changed deleted)
(should (file-notify-valid-p file-notify--test-desc))
(write-region
"any text" nil file-notify--test-tmpfile nil 'no-message)
- (should (file-notify-valid-p file-notify--test-desc)))
- ;; After removing the watch, the descriptor must not be valid
+ (delete-file file-notify--test-tmpfile))
+ ;; After deleting the file, the descriptor is still valid.
+ (should (file-notify-valid-p file-notify--test-desc))
+ ;; After removing the watch, the descriptor must not be valid
;; anymore.
(file-notify-rm-watch file-notify--test-desc)
(should-not (file-notify-valid-p file-notify--test-desc)))
@@ -457,26 +538,23 @@ Don't wait longer than TIMEOUT seconds for the events to
be delivered."
(unwind-protect
;; The batch-mode operation of w32notify is fragile (there's no
;; input threads to send the message to).
- (unless (and noninteractive (eq file-notify--library 'w32notify))
- (let ((temporary-file-directory (make-temp-file
- "file-notify-test-parent" t)))
- (setq file-notify--test-tmpfile (file-notify--test-make-temp-name))
- (setq file-notify--test-desc
+ ;(unless (and noninteractive (eq file-notify--library 'w32notify))
+ (unless (eq file-notify--library 'w32notify)
+ (let ((temporary-file-directory
+ (make-temp-file "file-notify-test-parent" t)))
+ (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)
+ file-notify--test-desc
(file-notify-add-watch
file-notify--test-tmpfile
'(change) #'file-notify--test-event-handler))
(file-notify--test-with-events
- (file-notify--test-timeout) '(created changed)
+ (file-notify--test-timeout) '(created changed deleted stopped)
(should (file-notify-valid-p file-notify--test-desc))
(write-region
"any text" nil file-notify--test-tmpfile nil 'no-message)
- (should (file-notify-valid-p file-notify--test-desc)))
- ;; After deleting the parent, the descriptor must not be valid
- ;; anymore.
- (delete-directory temporary-file-directory t)
- (file-notify--wait-for-events
- (file-notify--test-timeout)
- (not (file-notify-valid-p file-notify--test-desc)))
+ (delete-directory temporary-file-directory t))
+ ;; After deleting the parent directory, the descriptor must
+ ;; not be valid anymore.
(should-not (file-notify-valid-p file-notify--test-desc))))
;; Cleanup.
@@ -491,8 +569,8 @@ Don't wait longer than TIMEOUT seconds for the events to be
delivered."
(unwind-protect
(progn
- (setq file-notify--test-tmpfile (file-name-as-directory
- (file-notify--test-make-temp-name)))
+ (setq file-notify--test-tmpfile
+ (file-name-as-directory (file-notify--test-make-temp-name)))
(make-directory file-notify--test-tmpfile)
(setq file-notify--test-desc
(file-notify-add-watch
@@ -502,6 +580,9 @@ Don't wait longer than TIMEOUT seconds for the events to be
delivered."
;; After removing the watch, the descriptor must not be valid
;; anymore.
(file-notify-rm-watch file-notify--test-desc)
+ (file-notify--wait-for-events
+ (file-notify--test-timeout)
+ (not (file-notify-valid-p file-notify--test-desc)))
(should-not (file-notify-valid-p file-notify--test-desc)))
;; Cleanup.
@@ -511,8 +592,8 @@ Don't wait longer than TIMEOUT seconds for the events to be
delivered."
;; The batch-mode operation of w32notify is fragile (there's no
;; input threads to send the message to).
(unless (and noninteractive (eq file-notify--library 'w32notify))
- (setq file-notify--test-tmpfile (file-name-as-directory
- (file-notify--test-make-temp-name)))
+ (setq file-notify--test-tmpfile
+ (file-name-as-directory (file-notify--test-make-temp-name)))
(make-directory file-notify--test-tmpfile)
(setq file-notify--test-desc
(file-notify-add-watch
@@ -540,5 +621,10 @@ Don't wait longer than TIMEOUT seconds for the events to
be delivered."
(ert-run-tests-interactively "^file-notify-")
(ert-run-tests-batch "^file-notify-")))
+;; TODO:
+
+;; * It does not work yet for local gfilenotify and remote inotifywait.
+;; * For w32notify, no stopped events arrive when a directory is removed.
+
(provide 'file-notify-tests)
;;; file-notify-tests.el ends here
diff --git a/test/automated/simple-test.el b/test/automated/simple-test.el
new file mode 100644
index 0000000..5bfb746
--- /dev/null
+++ b/test/automated/simple-test.el
@@ -0,0 +1,206 @@
+;;; simple-test.el --- Tests for simple.el -*- lexical-binding: t;
-*-
+
+;; Copyright (C) 2015 Free Software Foundation, Inc.
+
+;; Author: Artur Malabarba <address@hidden>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert)
+
+(defmacro simple-test--dummy-buffer (&rest body)
+ (declare (indent 0)
+ (debug t))
+ `(with-temp-buffer
+ (emacs-lisp-mode)
+ (setq indent-tabs-mode nil)
+ (insert "(a b")
+ (save-excursion (insert " c d)"))
+ ,@body
+ (cons (buffer-substring (point-min) (point))
+ (buffer-substring (point) (point-max)))))
+
+
+
+;;; `newline'
+(ert-deftest newline ()
+ (should-error (newline -1))
+ (should (equal (simple-test--dummy-buffer (newline 1))
+ '("(a b\n" . " c d)")))
+ (should (equal (simple-test--dummy-buffer
+ (electric-indent-mode -1)
+ (call-interactively #'newline))
+ '("(a b\n" . " c d)")))
+ (should (equal (simple-test--dummy-buffer
+ (let ((current-prefix-arg 5))
+ (call-interactively #'newline)))
+ '("(a b\n\n\n\n\n" . " c d)")))
+ (should (equal (simple-test--dummy-buffer (newline 5))
+ '("(a b\n\n\n\n\n" . " c d)")))
+ (should (equal (simple-test--dummy-buffer
+ (forward-char 1)
+ (newline 1))
+ '("(a b \n" . "c d)"))))
+
+(ert-deftest newline-indent ()
+ (should (equal (simple-test--dummy-buffer
+ (electric-indent-local-mode 1)
+ (newline 1))
+ '("(a b\n" . " c d)")))
+ (should (equal (simple-test--dummy-buffer
+ (electric-indent-local-mode 1)
+ (newline 1 'interactive))
+ '("(a b\n " . "c d)")))
+ (should (equal (simple-test--dummy-buffer
+ (electric-indent-local-mode 1)
+ (let ((current-prefix-arg nil))
+ (call-interactively #'newline)
+ (call-interactively #'newline)))
+ '("(a b\n\n " . "c d)")))
+ (should (equal (simple-test--dummy-buffer
+ (electric-indent-local-mode 1)
+ (newline 5 'interactive))
+ '("(a b\n\n\n\n\n " . "c d)")))
+ (should (equal (simple-test--dummy-buffer
+ (electric-indent-local-mode 1)
+ (let ((current-prefix-arg 5))
+ (call-interactively #'newline)))
+ '("(a b\n\n\n\n\n " . "c d)")))
+ (should (equal (simple-test--dummy-buffer
+ (forward-char 1)
+ (electric-indent-local-mode 1)
+ (newline 1 'interactive))
+ '("(a b\n " . "c d)"))))
+
+
+;;; `open-line'
+(ert-deftest open-line ()
+ (should-error (open-line -1))
+ (should-error (open-line))
+ (should (equal (simple-test--dummy-buffer (open-line 1))
+ '("(a b" . "\n c d)")))
+ (should (equal (simple-test--dummy-buffer
+ (electric-indent-mode -1)
+ (call-interactively #'open-line))
+ '("(a b" . "\n c d)")))
+ (should (equal (simple-test--dummy-buffer
+ (let ((current-prefix-arg 5))
+ (call-interactively #'open-line)))
+ '("(a b" . "\n\n\n\n\n c d)")))
+ (should (equal (simple-test--dummy-buffer (open-line 5))
+ '("(a b" . "\n\n\n\n\n c d)")))
+ (should (equal (simple-test--dummy-buffer
+ (forward-char 1)
+ (open-line 1))
+ '("(a b " . "\nc d)"))))
+
+(ert-deftest open-line-margin-and-prefix ()
+ (should (equal (simple-test--dummy-buffer
+ (let ((left-margin 10))
+ (open-line 3)))
+ '("(a b" . "\n\n\n c d)")))
+ (should (equal (simple-test--dummy-buffer
+ (forward-line 0)
+ (let ((left-margin 2))
+ (open-line 1)))
+ '(" " . "\n (a b c d)")))
+ (should (equal (simple-test--dummy-buffer
+ (let ((fill-prefix "- - "))
+ (open-line 1)))
+ '("(a b" . "\n c d)")))
+ (should (equal (simple-test--dummy-buffer
+ (forward-line 0)
+ (let ((fill-prefix "- - "))
+ (open-line 1)))
+ '("- - " . "\n(a b c d)"))))
+
+(ert-deftest open-line-indent ()
+ (should (equal (simple-test--dummy-buffer
+ (electric-indent-local-mode 1)
+ (open-line 1))
+ '("(a b" . "\n c d)")))
+ (should (equal (simple-test--dummy-buffer
+ (electric-indent-local-mode 1)
+ (open-line 1 'interactive))
+ '("(a b" . "\n c d)")))
+ (should (equal (simple-test--dummy-buffer
+ (electric-indent-local-mode 1)
+ (let ((current-prefix-arg nil))
+ (call-interactively #'open-line)
+ (call-interactively #'open-line)))
+ '("(a b" . "\n\n c d)")))
+ (should (equal (simple-test--dummy-buffer
+ (electric-indent-local-mode 1)
+ (open-line 5 'interactive))
+ '("(a b" . "\n\n\n\n\n c d)")))
+ (should (equal (simple-test--dummy-buffer
+ (electric-indent-local-mode 1)
+ (let ((current-prefix-arg 5))
+ (call-interactively #'open-line)))
+ '("(a b" . "\n\n\n\n\n c d)")))
+ (should (equal (simple-test--dummy-buffer
+ (forward-char 1)
+ (electric-indent-local-mode 1)
+ (open-line 1 'interactive))
+ '("(a b" . "\n c d)"))))
+
+(ert-deftest open-line-hook ()
+ (let* ((x 0)
+ (inc (lambda () (setq x (1+ x)))))
+ (simple-test--dummy-buffer
+ (add-hook 'post-self-insert-hook inc nil 'local)
+ (open-line 1))
+ (should (= x 0))
+ (simple-test--dummy-buffer
+ (add-hook 'post-self-insert-hook inc nil 'local)
+ (open-line 1 'interactive))
+ (should (= x 1))
+
+ (unwind-protect
+ (progn
+ (add-hook 'post-self-insert-hook inc)
+ (simple-test--dummy-buffer
+ (open-line 1))
+ (should (= x 1))
+ (simple-test--dummy-buffer
+ (open-line 10 'interactive))
+ (should (= x 2)))
+ (remove-hook 'post-self-insert-hook inc))))
+
+
+;;; `delete-trailing-whitespace'
+(ert-deftest simple-delete-trailing-whitespace ()
+ "Test bug#21766: delete-whitespace sometimes deletes non-whitespace."
+ (defvar python-indent-guess-indent-offset) ; to avoid a warning
+ (let ((python (featurep 'python))
+ (python-indent-guess-indent-offset nil)
+ (delete-trailing-lines t))
+ (unwind-protect
+ (with-temp-buffer
+ (python-mode)
+ (insert (concat "query = \"\"\"WITH filtered AS \n"
+ "WHERE \n"
+ "\"\"\".format(fv_)\n"
+ "\n"
+ "\n"))
+ (delete-trailing-whitespace)
+ (should (equal (count-lines (point-min) (point-max)) 3)))
+ ;; Let's clean up if running interactive
+ (unless (or noninteractive python)
+ (unload-feature 'python)))))
+
+(provide 'simple-test)
+;;; simple-test.el ends here
diff --git a/test/automated/thunk-tests.el b/test/automated/thunk-tests.el
new file mode 100644
index 0000000..7abbd29
--- /dev/null
+++ b/test/automated/thunk-tests.el
@@ -0,0 +1,55 @@
+;;; thunk-tests.el --- Tests for thunk.el -*- lexical-binding: t -*-
+
+;; Copyright (C) 2015 Free Software Foundation, Inc.
+
+;; Author: Nicolas Petton <address@hidden>
+;; Maintainer: address@hidden
+
+;; 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:
+
+;; Tests for thunk.el
+
+;;; Code:
+
+(require 'ert)
+(require 'thunk)
+
+(ert-deftest thunk-should-be-lazy ()
+ (let (x)
+ (thunk-delay (setq x t))
+ (should (null x))))
+
+(ert-deftest thunk-can-be-evaluated ()
+ (let* (x
+ (thunk (thunk-delay (setq x t))))
+ (should-not (thunk-evaluated-p thunk))
+ (should (null x))
+ (thunk-force thunk)
+ (should (thunk-evaluated-p thunk))
+ (should x)))
+
+(ert-deftest thunk-evaluation-is-cached ()
+ (let* ((x 0)
+ (thunk (thunk-delay (setq x (1+ x)))))
+ (thunk-force thunk)
+ (should (= x 1))
+ (thunk-force thunk)
+ (should (= x 1))))
+
+(provide 'thunk-tests)
+;;; thunk-tests.el ends here