commit f09e9d292f31abeac37e83c3558d7b33a6a1abbf (HEAD, refs/remotes/origin/master) Author: Michal Nazarewicz Date: Fri Jun 8 09:20:43 2018 +0100 ; Tiny tpyo fix * src/xfaces.c (face-remapping-alist): remove an empty ‘(3)’ introduced in a docstring by mistake. diff --git a/src/xfaces.c b/src/xfaces.c index 1654f8610e..961bef7c9c 100644 --- a/src/xfaces.c +++ b/src/xfaces.c @@ -6694,7 +6694,6 @@ REPLACEMENT is a face specification, i.e. one of the following: (1) a face name (2) a property list of attribute/value pairs, or - (3) (3) a list in which each element has one of the above forms. List values for REPLACEMENT are merged to form the final face commit 416ba369c4ee2592d226eef68aeb4ad35ffea61d Author: Daniel Colascione Date: Thu Jun 7 22:05:33 2018 -0700 Offer to open large files without modes * lisp/files.el: (files--ask-user-about-large-file): New function. (abort-if-file-too-large): Call it. (find-file-noselect): Support new raw open. diff --git a/lisp/files.el b/lisp/files.el index dbe95bb665..3921040fa9 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -2014,17 +2014,47 @@ think it does, because \"free\" is pretty hard to define in practice." :version "25.1" :type '(choice integer (const :tag "Never issue warning" nil))) -(defun abort-if-file-too-large (size op-type filename) +(declare-function x-popup-dialog "menu.c" (position contents &optional header)) + +(defun files--ask-user-about-large-file (size op-type filename offer-raw) + (let ((prompt (format "File %s is large (%s), really %s?" + (file-name-nondirectory filename) + (file-size-human-readable size) op-type))) + (if (not offer-raw) + (if (y-or-n-p prompt) nil 'abort) + (let* ((use-dialog (and (display-popup-menus-p) + last-input-event + (listp last-nonmenu-event) + use-dialog-box)) + (choice + (if use-dialog + (x-popup-dialog t `(,prompt + ("Yes" . ?y) + ("No" . ?n) + ("Open in raw mode" . ?r))) + (read-char-choice + (concat prompt " (y)es or (n)o or (r)aw ") + '(?y ?Y ?n ?N ?r ?R))))) + (cond ((memq choice '(?y ?Y)) nil) + ((memq choice '(?r ?R)) 'raw) + (t 'abort)))))) + +(defun abort-if-file-too-large (size op-type filename &optional offer-raw) "If file SIZE larger than `large-file-warning-threshold', allow user to abort. -OP-TYPE specifies the file operation being performed (for message to user)." - (when (and large-file-warning-threshold size - (> size large-file-warning-threshold) - ;; No point in warning if we can't read it. - (file-readable-p filename) - (not (y-or-n-p (format "File %s is large (%s), really %s? " - (file-name-nondirectory filename) - (file-size-human-readable size) op-type)))) - (user-error "Aborted"))) +OP-TYPE specifies the file operation being performed (for message +to user). If OFFER-RAW is true, give user the additional option +to open the file in raw mode. If the user chooses this option, +`abort-if-file-too-large' returns the symbol `raw'. Otherwise, it +returns nil or exits non-locally." + (let ((choice (and large-file-warning-threshold size + (> size large-file-warning-threshold) + ;; No point in warning if we can't read it. + (file-readable-p filename) + (files--ask-user-about-large-file + size op-type filename offer-raw)))) + (when (eq choice 'abort) + (user-error "Aborted")) + choice)) (defun warn-maybe-out-of-memory (size) "Warn if an attempt to open file of SIZE bytes may run out of memory." @@ -2104,7 +2134,10 @@ the various files." (setq buf other)))) ;; Check to see if the file looks uncommonly large. (when (not (or buf nowarn)) - (abort-if-file-too-large (nth 7 attributes) "open" filename) + (when (eq (abort-if-file-too-large + (nth 7 attributes) "open" filename t) + 'raw) + (setf rawfile t)) (warn-maybe-out-of-memory (nth 7 attributes))) (if buf ;; We are using an existing buffer. commit 9d447fa1562c69f2224bdefc37703c0eb0f7d7cf Author: Daniel Colascione Date: Thu Jun 7 16:20:06 2018 -0700 Add support for per-window face remapping Extend face specifications to support the notion of filtering to a specific context and add a filter that limits a face specification to windows having a certain parameter. * src/xfaces.c: (evaluate_face_filter,filter_face_ref): New functions. (merge_face_ref): Ignore filtered face specifications. (Fx_list_fonts,get_lface_attributes,merge_face_vectors) (merge_named_face,merge_face_ref,merge_face_ref) (Finternal_merge_in_global_face,Fface_font,lookup_named_face) (lookup_basic_face,Fface_attributes_as_vector) (x_supports_face_attributes_p) (Fdisplay_supports_face_attributes_p,realize_named_face) (compute_char_face,face_at_buffer_position) (face_at_buffer_position,face_at_buffer_position) (face_at_buffer_position) (face_for_overlay_string,face_at_string_position,merge_faces): Pass window to face machinery. (syms_of_xfaces): Add :window and :filtered * src/xdisp.c (init_iterator, handle_face_prop) (handle_single_display_spec, merge_escape_glyph_face) (merge_glyphless_glyph_face, get_next_display_element) (next_element_from_display_vector, append_space_for_newline) (extend_face_to_end_of_line,highlight_trailing_whitespace) (maybe_produce_line_number) (display_line, calc_line_height_property): Pass window to face machinery. * src/term.c (tty_menu_activate): Adjust to new face core function signature. * src/msdos.c (XMenuActivate): Adjust to new face core function signature. * src/fringe.c (draw_fringe_bitmap_1, Fset_fringe_bitmap_face): Pass window to face machinery. * src/font.c (font_range, Finternal_char_font): Pass window to face machinery. * src/dispnew.c (spec_glyph_lookup_face): Pass window to face machinery. * src/dispextern.h: (lookup_named_face,lookup_basic_face) (lookup_derived_face,merge_faces): Add struct window arguments to prototypes. diff --git a/etc/NEWS b/etc/NEWS index d6b7485f7f..3282340f91 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -572,6 +572,11 @@ manual for more details. * Lisp Changes in Emacs 27.1 ++++ +** Face specifications (of the kind used in `face-remapping-alist') + now support filters, allowing faces to vary between windows display + the same buffer. + +++ ** New function assoc-delete-all. diff --git a/src/dispextern.h b/src/dispextern.h index bc2a76f1e0..2180c9ae63 100644 --- a/src/dispextern.h +++ b/src/dispextern.h @@ -3429,11 +3429,12 @@ char *choose_face_font (struct frame *, Lisp_Object *, Lisp_Object, #ifdef HAVE_WINDOW_SYSTEM void prepare_face_for_display (struct frame *, struct face *); #endif -int lookup_named_face (struct frame *, Lisp_Object, bool); -int lookup_basic_face (struct frame *, int); +int lookup_named_face (struct window *, struct frame *, Lisp_Object, bool); +int lookup_basic_face (struct window *, struct frame *, int); int smaller_face (struct frame *, int, int); int face_with_height (struct frame *, int, int); -int lookup_derived_face (struct frame *, Lisp_Object, int, bool); +int lookup_derived_face (struct window *, struct frame *, + Lisp_Object, int, bool); void init_frame_faces (struct frame *); void free_frame_faces (struct frame *); void recompute_basic_faces (struct frame *); @@ -3443,7 +3444,7 @@ int face_for_overlay_string (struct window *, ptrdiff_t, ptrdiff_t *, ptrdiff_t, bool, Lisp_Object); int face_at_string_position (struct window *, Lisp_Object, ptrdiff_t, ptrdiff_t, ptrdiff_t *, enum face_id, bool); -int merge_faces (struct frame *, Lisp_Object, int, int); +int merge_faces (struct window *, Lisp_Object, int, int); int compute_char_face (struct frame *, int, Lisp_Object); void free_all_realized_faces (Lisp_Object); extern char unspecified_fg[], unspecified_bg[]; diff --git a/src/dispnew.c b/src/dispnew.c index b854d179d5..46e0c83ef6 100644 --- a/src/dispnew.c +++ b/src/dispnew.c @@ -2508,8 +2508,7 @@ spec_glyph_lookup_face (struct window *w, GLYPH *glyph) /* Convert the glyph's specified face to a realized (cache) face. */ if (lface_id > 0) { - int face_id = merge_faces (XFRAME (w->frame), - Qt, lface_id, DEFAULT_FACE_ID); + int face_id = merge_faces (w, Qt, lface_id, DEFAULT_FACE_ID); SET_GLYPH_FACE (*glyph, face_id); } } diff --git a/src/font.c b/src/font.c index 305bb14576..c886c299d1 100644 --- a/src/font.c +++ b/src/font.c @@ -3810,7 +3810,7 @@ font_range (ptrdiff_t pos, ptrdiff_t pos_byte, ptrdiff_t *limit, face_id = NILP (Vface_remapping_alist) ? DEFAULT_FACE_ID - : lookup_basic_face (f, DEFAULT_FACE_ID); + : lookup_basic_face (w, f, DEFAULT_FACE_ID); face_id = face_at_string_position (w, string, pos, 0, &ignore, face_id, false); @@ -4559,7 +4559,7 @@ DEFUN ("internal-char-font", Finternal_char_font, Sinternal_char_font, 1, 2, 0, CHECK_CHARACTER (ch); c = XINT (ch); f = XFRAME (selected_frame); - face_id = lookup_basic_face (f, DEFAULT_FACE_ID); + face_id = lookup_basic_face (NULL, f, DEFAULT_FACE_ID); pos = -1; } else diff --git a/src/fringe.c b/src/fringe.c index 85aa14da72..6069184681 100644 --- a/src/fringe.c +++ b/src/fringe.c @@ -587,8 +587,8 @@ draw_fringe_bitmap_1 (struct window *w, struct glyph_row *row, int left_p, int o if (face_id == DEFAULT_FACE_ID) { Lisp_Object face = fringe_faces[which]; - face_id = NILP (face) ? lookup_named_face (f, Qfringe, false) - : lookup_derived_face (f, face, FRINGE_FACE_ID, 0); + face_id = NILP (face) ? lookup_named_face (w, f, Qfringe, false) + : lookup_derived_face (w, f, face, FRINGE_FACE_ID, 0); if (face_id < 0) face_id = FRINGE_FACE_ID; } @@ -1633,20 +1633,10 @@ If FACE is nil, reset face to default fringe face. */) if (!n) error ("Undefined fringe bitmap"); - /* The purpose of the following code is to signal an error if FACE - is not a face. This is for the caller's convenience only; the - redisplay code should be able to fail gracefully. Skip the check - if FRINGE_FACE_ID is unrealized (as in batch mode and during - daemon startup). */ - if (!NILP (face)) - { - struct frame *f = SELECTED_FRAME (); - - if (FACE_FROM_ID_OR_NULL (f, FRINGE_FACE_ID) - && lookup_derived_face (f, face, FRINGE_FACE_ID, 1) < 0) - error ("No such face"); - } - + /* We used to check, as a convenience to callers, for basic face + validity here, but since validity can depend on the specific + _window_ in which this buffer is being displayed, defer the check + to redisplay, which can cope with bad face specifications. */ fringe_faces[n] = face; return Qnil; } diff --git a/src/msdos.c b/src/msdos.c index eedbf7b1a6..6c0dfa0c46 100644 --- a/src/msdos.c +++ b/src/msdos.c @@ -3063,15 +3063,15 @@ XMenuActivate (Display *foo, XMenu *menu, int *pane, int *selidx, state = alloca (menu->panecount * sizeof (struct IT_menu_state)); screensize = screen_size * 2; faces[0] - = lookup_derived_face (sf, intern ("msdos-menu-passive-face"), + = lookup_derived_face (NULL, sf, intern ("msdos-menu-passive-face"), DEFAULT_FACE_ID, 1); faces[1] - = lookup_derived_face (sf, intern ("msdos-menu-active-face"), + = lookup_derived_face (NULL, sf, intern ("msdos-menu-active-face"), DEFAULT_FACE_ID, 1); selectface = intern ("msdos-menu-select-face"); - faces[2] = lookup_derived_face (sf, selectface, + faces[2] = lookup_derived_face (NULL, sf, selectface, faces[0], 1); - faces[3] = lookup_derived_face (sf, selectface, + faces[3] = lookup_derived_face (NULL, sf, selectface, faces[1], 1); /* Make sure the menu title is always displayed with diff --git a/src/term.c b/src/term.c index 08d483f4fa..bcd7dd82d6 100644 --- a/src/term.c +++ b/src/term.c @@ -3132,15 +3132,15 @@ tty_menu_activate (tty_menu *menu, int *pane, int *selidx, SAFE_NALLOCA (state, 1, menu->panecount); memset (state, 0, sizeof (*state)); faces[0] - = lookup_derived_face (sf, intern ("tty-menu-disabled-face"), + = lookup_derived_face (NULL, sf, intern ("tty-menu-disabled-face"), DEFAULT_FACE_ID, 1); faces[1] - = lookup_derived_face (sf, intern ("tty-menu-enabled-face"), + = lookup_derived_face (NULL, sf, intern ("tty-menu-enabled-face"), DEFAULT_FACE_ID, 1); selectface = intern ("tty-menu-selected-face"); - faces[2] = lookup_derived_face (sf, selectface, + faces[2] = lookup_derived_face (NULL, sf, selectface, faces[0], 1); - faces[3] = lookup_derived_face (sf, selectface, + faces[3] = lookup_derived_face (NULL, sf, selectface, faces[1], 1); /* Make sure the menu title is always displayed with diff --git a/src/xdisp.c b/src/xdisp.c index ad1c044557..a2b6513e57 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -2809,7 +2809,7 @@ init_iterator (struct it *it, struct window *w, /* Perhaps remap BASE_FACE_ID to a user-specified alternative. */ if (! NILP (Vface_remapping_alist)) remapped_base_face_id - = lookup_basic_face (XFRAME (w->frame), base_face_id); + = lookup_basic_face (w, XFRAME (w->frame), base_face_id); /* Use one of the mode line rows of W's desired matrix if appropriate. */ @@ -4060,7 +4060,7 @@ handle_face_prop (struct it *it) might be a big deal. */ base_face_id = it->string_from_prefix_prop_p ? (!NILP (Vface_remapping_alist) - ? lookup_basic_face (it->f, DEFAULT_FACE_ID) + ? lookup_basic_face (it->w, it->f, DEFAULT_FACE_ID) : DEFAULT_FACE_ID) : underlying_face_id (it); } @@ -4988,7 +4988,7 @@ handle_single_display_spec (struct it *it, Lisp_Object spec, Lisp_Object object, struct face *f; f = FACE_FROM_ID (it->f, - lookup_basic_face (it->f, DEFAULT_FACE_ID)); + lookup_basic_face (it->w, it->f, DEFAULT_FACE_ID)); new_height = (XFLOATINT (it->font_height) * XINT (f->lface[LFACE_HEIGHT_INDEX])); } @@ -5175,12 +5175,12 @@ handle_single_display_spec (struct it *it, Lisp_Object spec, Lisp_Object object, if (it) { - int face_id = lookup_basic_face (it->f, DEFAULT_FACE_ID); + int face_id = lookup_basic_face (it->w, it->f, DEFAULT_FACE_ID); if (CONSP (XCDR (XCDR (spec)))) { Lisp_Object face_name = XCAR (XCDR (XCDR (spec))); - int face_id2 = lookup_derived_face (it->f, face_name, + int face_id2 = lookup_derived_face (it->w, it->f, face_name, FRINGE_FACE_ID, false); if (face_id2 >= 0) face_id = face_id2; @@ -6985,7 +6985,7 @@ merge_escape_glyph_face (struct it *it) else { /* Merge the `escape-glyph' face into the current face. */ - face_id = merge_faces (it->f, Qescape_glyph, 0, it->face_id); + face_id = merge_faces (it->w, Qescape_glyph, 0, it->face_id); last_escape_glyph_frame = it->f; last_escape_glyph_face_id = it->face_id; last_escape_glyph_merged_face_id = face_id; @@ -7010,7 +7010,7 @@ merge_glyphless_glyph_face (struct it *it) else { /* Merge the `glyphless-char' face into the current face. */ - face_id = merge_faces (it->f, Qglyphless_char, 0, it->face_id); + face_id = merge_faces (it->w, Qglyphless_char, 0, it->face_id); last_glyphless_glyph_frame = it->f; last_glyphless_glyph_face_id = it->face_id; last_glyphless_glyph_merged_face_id = face_id; @@ -7184,7 +7184,7 @@ get_next_display_element (struct it *it) } face_id = (lface_id - ? merge_faces (it->f, Qt, lface_id, it->face_id) + ? merge_faces (it->w, Qt, lface_id, it->face_id) : merge_escape_glyph_face (it)); XSETINT (it->ctl_chars[0], g); @@ -7199,7 +7199,7 @@ get_next_display_element (struct it *it) if (nonascii_space_p && EQ (Vnobreak_char_display, Qt)) { /* Merge `nobreak-space' into the current face. */ - face_id = merge_faces (it->f, Qnobreak_space, 0, + face_id = merge_faces (it->w, Qnobreak_space, 0, it->face_id); XSETINT (it->ctl_chars[0], ' '); ctl_len = 1; @@ -7212,7 +7212,7 @@ get_next_display_element (struct it *it) if (nonascii_hyphen_p && EQ (Vnobreak_char_display, Qt)) { /* Merge `nobreak-space' into the current face. */ - face_id = merge_faces (it->f, Qnobreak_hyphen, 0, + face_id = merge_faces (it->w, Qnobreak_hyphen, 0, it->face_id); XSETINT (it->ctl_chars[0], '-'); ctl_len = 1; @@ -7232,7 +7232,7 @@ get_next_display_element (struct it *it) } face_id = (lface_id - ? merge_faces (it->f, Qt, lface_id, it->face_id) + ? merge_faces (it->w, Qt, lface_id, it->face_id) : merge_escape_glyph_face (it)); /* Draw non-ASCII space/hyphen with escape glyph: */ @@ -7860,7 +7860,7 @@ next_element_from_display_vector (struct it *it) { int lface_id = GLYPH_CODE_FACE (gc); if (lface_id > 0) - it->face_id = merge_faces (it->f, Qt, lface_id, + it->face_id = merge_faces (it->w, Qt, lface_id, it->saved_face_id); } @@ -7889,7 +7889,7 @@ next_element_from_display_vector (struct it *it) GLYPH_CODE_FACE (it->dpvec[it->current.dpvec_index + 1]); if (lface_id > 0) - next_face_id = merge_faces (it->f, Qt, lface_id, + next_face_id = merge_faces (it->w, Qt, lface_id, it->saved_face_id); } } @@ -20084,7 +20084,7 @@ append_space_for_newline (struct it *it, bool default_face_p) /* If the default face was remapped, be sure to use the remapped face for the appended newline. */ if (default_face_p) - it->face_id = lookup_basic_face (it->f, DEFAULT_FACE_ID); + it->face_id = lookup_basic_face (it->w, it->f, DEFAULT_FACE_ID); else if (it->face_before_selective_p) it->face_id = it->saved_face_id; face = FACE_FROM_ID (it->f, it->face_id); @@ -20231,8 +20231,9 @@ extend_face_to_end_of_line (struct it *it) return; /* The default face, possibly remapped. */ - default_face = FACE_FROM_ID_OR_NULL (f, - lookup_basic_face (f, DEFAULT_FACE_ID)); + default_face = FACE_FROM_ID_OR_NULL ( + f, + lookup_basic_face (it->w, f, DEFAULT_FACE_ID)); /* Face extension extends the background and box of IT->face_id to the end of the line. If the background equals the background @@ -20486,11 +20487,12 @@ trailing_whitespace_p (ptrdiff_t charpos) } -/* Highlight trailing whitespace, if any, in ROW. */ +/* Highlight trailing whitespace, if any, in row at IT. */ static void -highlight_trailing_whitespace (struct frame *f, struct glyph_row *row) +highlight_trailing_whitespace (struct it *it) { + struct glyph_row *row = it->glyph_row; int used = row->used[TEXT_AREA]; if (used) @@ -20535,7 +20537,7 @@ highlight_trailing_whitespace (struct frame *f, struct glyph_row *row) && glyph->u.ch == ' ')) && trailing_whitespace_p (glyph->charpos)) { - int face_id = lookup_named_face (f, Qtrailing_whitespace, false); + int face_id = lookup_named_face (it->w, it->f, Qtrailing_whitespace, false); if (face_id < 0) return; @@ -21107,9 +21109,9 @@ maybe_produce_line_number (struct it *it) char lnum_buf[INT_STRLEN_BOUND (ptrdiff_t) + 1]; bool beyond_zv = IT_BYTEPOS (*it) >= ZV_BYTE ? true : false; ptrdiff_t lnum_offset = -1; /* to produce 1-based line numbers */ - int lnum_face_id = merge_faces (it->f, Qline_number, 0, DEFAULT_FACE_ID); + int lnum_face_id = merge_faces (it->w, Qline_number, 0, DEFAULT_FACE_ID); int current_lnum_face_id - = merge_faces (it->f, Qline_number_current_line, 0, DEFAULT_FACE_ID); + = merge_faces (it->w, Qline_number_current_line, 0, DEFAULT_FACE_ID); /* Compute point's line number if needed. */ if ((EQ (Vdisplay_line_numbers, Qrelative) || EQ (Vdisplay_line_numbers, Qvisual) @@ -21559,7 +21561,8 @@ display_line (struct it *it, int cursor_vpos) portions of the screen will clear with the default face's background color. */ if (row->reversed_p - || lookup_basic_face (it->f, DEFAULT_FACE_ID) != DEFAULT_FACE_ID) + || lookup_basic_face (it->w, it->f, DEFAULT_FACE_ID) + != DEFAULT_FACE_ID) extend_face_to_end_of_line (it); break; } @@ -22192,7 +22195,7 @@ display_line (struct it *it, int cursor_vpos) /* Highlight trailing whitespace. */ if (!NILP (Vshow_trailing_whitespace)) - highlight_trailing_whitespace (it->f, it->glyph_row); + highlight_trailing_whitespace (it); /* Compute pixel dimensions of this line. */ compute_line_metrics (it); @@ -27862,7 +27865,7 @@ calc_line_height_property (struct it *it, Lisp_Object val, struct font *font, int face_id; struct face *face; - face_id = lookup_named_face (it->f, face_name, false); + face_id = lookup_named_face (it->w, it->f, face_name, false); face = FACE_FROM_ID_OR_NULL (it->f, face_id); if (face == NULL || ((font = face->font) == NULL)) return make_number (-1); diff --git a/src/xfaces.c b/src/xfaces.c index a9c2f37e9f..1654f8610e 100644 --- a/src/xfaces.c +++ b/src/xfaces.c @@ -350,7 +350,8 @@ static bool realize_default_face (struct frame *); static void realize_named_face (struct frame *, Lisp_Object, int); static struct face_cache *make_face_cache (struct frame *); static void free_face_cache (struct face_cache *); -static bool merge_face_ref (struct frame *, Lisp_Object, Lisp_Object *, +static bool merge_face_ref (struct window *w, + struct frame *, Lisp_Object, Lisp_Object *, bool, struct named_merge_point *); static int color_distance (XColor *x, XColor *y); @@ -1551,7 +1552,7 @@ the WIDTH times as wide as FACE on FRAME. */) { /* This is of limited utility since it works with character widths. Keep it for compatibility. --gerd. */ - int face_id = lookup_named_face (f, face, false); + int face_id = lookup_named_face (NULL, f, face, false); struct face *width_face = FACE_FROM_ID_OR_NULL (f, face_id); if (width_face && width_face->font) @@ -1907,19 +1908,22 @@ get_lface_attributes_no_remap (struct frame *f, Lisp_Object face_name, return !NILP (lface); } -/* Get face attributes of face FACE_NAME from frame-local faces on frame - F. Store the resulting attributes in ATTRS which must point to a - vector of Lisp_Objects of size LFACE_VECTOR_SIZE. If FACE_NAME is an - alias for another face, use that face's definition. - If SIGNAL_P, signal an error if FACE_NAME does not name a face. - Otherwise, return true iff FACE_NAME is a face. */ - +/* Get face attributes of face FACE_NAME from frame-local faces on + frame F. Store the resulting attributes in ATTRS which must point + to a vector of Lisp_Objects of size LFACE_VECTOR_SIZE. + If FACE_NAME is an alias for another face, use that face's + definition. If SIGNAL_P, signal an error if FACE_NAME does not + name a face. Otherwise, return true iff FACE_NAME is a face. If W + is non-NULL, also consider remappings attached to the window. + */ static bool -get_lface_attributes (struct frame *f, Lisp_Object face_name, +get_lface_attributes (struct window *w, + struct frame *f, Lisp_Object face_name, Lisp_Object attrs[LFACE_VECTOR_SIZE], bool signal_p, struct named_merge_point *named_merge_points) { Lisp_Object face_remapping; + eassert (w == NULL || WINDOW_XFRAME (w) == f); face_name = resolve_face_name (face_name, signal_p); @@ -1939,7 +1943,7 @@ get_lface_attributes (struct frame *f, Lisp_Object face_name, for (i = 1; i < LFACE_VECTOR_SIZE; ++i) attrs[i] = Qunspecified; - return merge_face_ref (f, XCDR (face_remapping), attrs, + return merge_face_ref (w, f, XCDR (face_remapping), attrs, signal_p, named_merge_points); } } @@ -2072,15 +2076,16 @@ merge_face_heights (Lisp_Object from, Lisp_Object to, Lisp_Object invalid) /* Merge two Lisp face attribute vectors on frame F, FROM and TO, and store the resulting attributes in TO, which must be already be - completely specified and contain only absolute attributes. Every - specified attribute of FROM overrides the corresponding attribute of - TO; relative attributes in FROM are merged with the absolute value in - TO and replace it. NAMED_MERGE_POINTS is used internally to detect - loops in face inheritance/remapping; it should be 0 when called from - other places. */ - + completely specified and contain only absolute attributes. + Every specified attribute of FROM overrides the corresponding + attribute of TO; relative attributes in FROM are merged with the + absolute value in TO and replace it. NAMED_MERGE_POINTS is used + internally to detect loops in face inheritance/remapping; it should + be 0 when called from other places. If window W is non-NULL, use W + to interpret face specifications. */ static void -merge_face_vectors (struct frame *f, Lisp_Object *from, Lisp_Object *to, +merge_face_vectors (struct window *w, + struct frame *f, Lisp_Object *from, Lisp_Object *to, struct named_merge_point *named_merge_points) { int i; @@ -2093,7 +2098,8 @@ merge_face_vectors (struct frame *f, Lisp_Object *from, Lisp_Object *to, other code uses `unspecified' as a generic value for face attributes. */ if (!UNSPECIFIEDP (from[LFACE_INHERIT_INDEX]) && !NILP (from[LFACE_INHERIT_INDEX])) - merge_face_ref (f, from[LFACE_INHERIT_INDEX], to, false, named_merge_points); + merge_face_ref (w, f, from[LFACE_INHERIT_INDEX], + to, false, named_merge_points); if (FONT_SPEC_P (from[LFACE_FONT_INDEX])) { @@ -2153,10 +2159,12 @@ merge_face_vectors (struct frame *f, Lisp_Object *from, Lisp_Object *to, /* Merge the named face FACE_NAME on frame F, into the vector of face attributes TO. Use NAMED_MERGE_POINTS to detect loops in face inheritance. Return true if FACE_NAME is a valid face name and - merging succeeded. */ + merging succeeded. Window W, if non-NULL, is used to filter face + specifications. */ static bool -merge_named_face (struct frame *f, Lisp_Object face_name, Lisp_Object *to, +merge_named_face (struct window *w, + struct frame *f, Lisp_Object face_name, Lisp_Object *to, struct named_merge_point *named_merge_points) { struct named_merge_point named_merge_point; @@ -2166,11 +2174,11 @@ merge_named_face (struct frame *f, Lisp_Object face_name, Lisp_Object *to, &named_merge_points)) { Lisp_Object from[LFACE_VECTOR_SIZE]; - bool ok = get_lface_attributes (f, face_name, from, false, + bool ok = get_lface_attributes (w, f, face_name, from, false, named_merge_points); if (ok) - merge_face_vectors (f, from, to, named_merge_points); + merge_face_vectors (w, f, from, to, named_merge_points); return ok; } @@ -2178,6 +2186,111 @@ merge_named_face (struct frame *f, Lisp_Object face_name, Lisp_Object *to, return false; } +/* Determine whether the face filter FILTER evaluated in window W + matches. W can be NULL if the window context is unknown. + + A face filter is either nil, which always matches, or a list + (:window PARAMETER VALUE), which matches if the current window has + a PARAMETER EQ to VALUE. + + If the filter is invalid, set *OK to false and, if ERR_MSGS is + true, log an error message. */ +static bool +evaluate_face_filter (Lisp_Object filter, struct window *w, + bool *ok, bool err_msgs) +{ + Lisp_Object orig_filter = filter; + + { + if (NILP (filter)) + return true; + + if (face_filters_always_match) + return true; + + if (!CONSP (filter)) + goto err; + + if (!EQ (XCAR (filter), Qwindow_kw)) + goto err; + filter = XCDR (filter); + + Lisp_Object parameter = XCAR (filter); + filter = XCDR (filter); + if (!CONSP (filter)) + goto err; + + Lisp_Object value = XCAR (filter); + filter = XCDR (filter); + if (!NILP (filter)) + goto err; + + bool match = false; + if (w) { + Lisp_Object found = assq_no_quit (parameter, w->window_parameters); + if (!NILP (found) && EQ (XCDR (found), value)) + match = true; + } + + return match; + } + + err: + if (err_msgs) + add_to_log ("Invalid face filter %S", orig_filter); + *ok = false; + return false; +} + +/* Determine whether FACE_REF is a "filter" face specification (case + #4 in merge_face_ref). If it is, evaluate the filter, and if the + filter matches, return the filtered expression. Otherwise, return + the original expression. + + On error, set *OK to false, having logged an error message if + ERR_MSGS is true, with return value unspecified. + + W is either NULL or a window used to evaluate filters. If W is + null, no window-based face specification filter matches. +*/ +static Lisp_Object +filter_face_ref (Lisp_Object face_ref, + struct window *w, + bool *ok, + bool err_msgs) +{ + Lisp_Object orig_face_ref = face_ref; + if (!CONSP (face_ref)) + return face_ref; + + { + if (!EQ (XCAR (face_ref), Qfiltered_kw)) + return face_ref; + face_ref = XCDR (face_ref); + + if (!CONSP (face_ref)) + goto err; + Lisp_Object filter = XCAR (face_ref); + face_ref = XCDR (face_ref); + + if (!CONSP (face_ref)) + goto err; + Lisp_Object filtered_face_ref = XCAR (face_ref); + face_ref = XCDR (face_ref); + + if (!NILP (face_ref)) + goto err; + + return evaluate_face_filter (filter, w, ok, err_msgs) + ? filtered_face_ref : Qnil; + } + + err: + if (err_msgs) + add_to_log ("Invalid face ref %S", orig_face_ref); + *ok = false; + return Qnil; +} /* Merge face attributes from the lisp `face reference' FACE_REF on frame F into the face attribute vector TO. If ERR_MSGS, @@ -2199,21 +2312,44 @@ merge_named_face (struct frame *f, Lisp_Object face_name, Lisp_Object *to, (BACKGROUND-COLOR . COLOR) where COLOR is a color name. This is for compatibility with 20.2. + 4. Conses of the form + (:filter (:window PARAMETER VALUE) FACE-SPECIFICATION), + which applies FACE-SPECIFICATION only if the + given face attributes are being evaluated in the context of a + window with a parameter named PARAMETER being EQ VALUE. + + 5. nil, which means to merge nothing. + Face specifications earlier in lists take precedence over later specifications. */ static bool -merge_face_ref (struct frame *f, Lisp_Object face_ref, Lisp_Object *to, +merge_face_ref (struct window *w, + struct frame *f, Lisp_Object face_ref, Lisp_Object *to, bool err_msgs, struct named_merge_point *named_merge_points) { bool ok = true; /* Succeed without an error? */ + Lisp_Object filtered_face_ref; + + filtered_face_ref = face_ref; + do + { + face_ref = filtered_face_ref; + filtered_face_ref = filter_face_ref (face_ref, w, &ok, err_msgs); + } while (ok && !EQ (face_ref, filtered_face_ref)); + + if (!ok) + return false; + + if (NILP (face_ref)) + return true; if (CONSP (face_ref)) { Lisp_Object first = XCAR (face_ref); if (EQ (first, Qforeground_color) - || EQ (first, Qbackground_color)) + || EQ (first, Qbackground_color)) { /* One of (FOREGROUND-COLOR . COLOR) or (BACKGROUND-COLOR . COLOR). COLOR must be a string. */ @@ -2400,7 +2536,7 @@ merge_face_ref (struct frame *f, Lisp_Object face_ref, Lisp_Object *to, { /* This is not really very useful; it's just like a normal face reference. */ - if (! merge_face_ref (f, value, to, + if (! merge_face_ref (w, f, value, to, err_msgs, named_merge_points)) err = true; } @@ -2424,16 +2560,16 @@ merge_face_ref (struct frame *f, Lisp_Object face_ref, Lisp_Object *to, Lisp_Object next = XCDR (face_ref); if (! NILP (next)) - ok = merge_face_ref (f, next, to, err_msgs, named_merge_points); + ok = merge_face_ref (w, f, next, to, err_msgs, named_merge_points); - if (! merge_face_ref (f, first, to, err_msgs, named_merge_points)) + if (! merge_face_ref (w, f, first, to, err_msgs, named_merge_points)) ok = false; } } else { /* FACE_REF ought to be a face name. */ - ok = merge_named_face (f, face_ref, to, named_merge_points); + ok = merge_named_face (w, f, face_ref, to, named_merge_points); if (!ok && err_msgs) add_to_log ("Invalid face reference: %s", face_ref); } @@ -3701,7 +3837,7 @@ Default face attributes override any local face attributes. */) /* Ensure that the face vector is fully specified by merging the previously-cached vector. */ memcpy (attrs, oldface->lface, sizeof attrs); - merge_face_vectors (f, lvec, attrs, 0); + merge_face_vectors (NULL, f, lvec, attrs, 0); vcopy (local_lface, 0, attrs, LFACE_VECTOR_SIZE); newface = realize_face (c, lvec, DEFAULT_FACE_ID); @@ -3774,7 +3910,7 @@ return the font name used for CHARACTER. */) else { struct frame *f = decode_live_frame (frame); - int face_id = lookup_named_face (f, face, true); + int face_id = lookup_named_face (NULL, f, face, true); struct face *fface = FACE_FROM_ID_OR_NULL (f, face_id); if (! fface) @@ -4432,10 +4568,12 @@ face_for_font (struct frame *f, Lisp_Object font_object, struct face *base_face) /* Return the face id of the realized face for named face SYMBOL on frame F suitable for displaying ASCII characters. Value is -1 if the face couldn't be determined, which might happen if the default - face isn't realized and cannot be realized. */ - + face isn't realized and cannot be realized. If window W is given, + consider face remappings specified for W or for W's buffer. If W is + NULL, consider only frame-level face configuration. */ int -lookup_named_face (struct frame *f, Lisp_Object symbol, bool signal_p) +lookup_named_face (struct window *w, struct frame *f, + Lisp_Object symbol, bool signal_p) { Lisp_Object attrs[LFACE_VECTOR_SIZE]; Lisp_Object symbol_attrs[LFACE_VECTOR_SIZE]; @@ -4448,11 +4586,11 @@ lookup_named_face (struct frame *f, Lisp_Object symbol, bool signal_p) default_face = FACE_FROM_ID (f, DEFAULT_FACE_ID); } - if (! get_lface_attributes (f, symbol, symbol_attrs, signal_p, 0)) + if (! get_lface_attributes (w, f, symbol, symbol_attrs, signal_p, 0)) return -1; memcpy (attrs, default_face->lface, sizeof attrs); - merge_face_vectors (f, symbol_attrs, attrs, 0); + merge_face_vectors (w, f, symbol_attrs, attrs, 0); return lookup_face (f, attrs); } @@ -4462,10 +4600,10 @@ lookup_named_face (struct frame *f, Lisp_Object symbol, bool signal_p) is FACE_ID. The return value will usually simply be FACE_ID, unless that basic face has bee remapped via Vface_remapping_alist. This function is conservative: if something goes wrong, it will simply return FACE_ID - rather than signal an error. */ - + rather than signal an error. Window W, if non-NULL, is used to filter + face specifications for remapping. */ int -lookup_basic_face (struct frame *f, int face_id) +lookup_basic_face (struct window *w, struct frame *f, int face_id) { Lisp_Object name, mapping; int remapped_face_id; @@ -4505,7 +4643,7 @@ lookup_basic_face (struct frame *f, int face_id) /* If there is a remapping entry, lookup the face using NAME, which will handle the remapping too. */ - remapped_face_id = lookup_named_face (f, name, false); + remapped_face_id = lookup_named_face (w, f, name, false); if (remapped_face_id < 0) return face_id; /* Give up. */ @@ -4603,22 +4741,23 @@ face_with_height (struct frame *f, int face_id, int height) attributes of the face FACE_ID for attributes that aren't completely specified by SYMBOL. This is like lookup_named_face, except that the default attributes come from FACE_ID, not from the - default face. FACE_ID is assumed to be already realized. */ - + default face. FACE_ID is assumed to be already realized. + Window W, if non-NULL, filters face specifications. */ int -lookup_derived_face (struct frame *f, Lisp_Object symbol, int face_id, +lookup_derived_face (struct window *w, + struct frame *f, Lisp_Object symbol, int face_id, bool signal_p) { Lisp_Object attrs[LFACE_VECTOR_SIZE]; Lisp_Object symbol_attrs[LFACE_VECTOR_SIZE]; struct face *default_face; - if (!get_lface_attributes (f, symbol, symbol_attrs, signal_p, 0)) + if (!get_lface_attributes (w, f, symbol, symbol_attrs, signal_p, 0)) return -1; default_face = FACE_FROM_ID (f, face_id); memcpy (attrs, default_face->lface, sizeof attrs); - merge_face_vectors (f, symbol_attrs, attrs, 0); + merge_face_vectors (w, f, symbol_attrs, attrs, 0); return lookup_face (f, attrs); } @@ -4630,7 +4769,8 @@ DEFUN ("face-attributes-as-vector", Fface_attributes_as_vector, Lisp_Object lface; lface = Fmake_vector (make_number (LFACE_VECTOR_SIZE), Qunspecified); - merge_face_ref (XFRAME (selected_frame), plist, XVECTOR (lface)->contents, + merge_face_ref (NULL, XFRAME (selected_frame), + plist, XVECTOR (lface)->contents, true, 0); return lface; } @@ -4714,7 +4854,7 @@ x_supports_face_attributes_p (struct frame *f, memcpy (merged_attrs, def_attrs, sizeof merged_attrs); - merge_face_vectors (f, attrs, merged_attrs, 0); + merge_face_vectors (NULL, f, attrs, merged_attrs, 0); face_id = lookup_face (f, merged_attrs); face = FACE_FROM_ID_OR_NULL (f, face_id); @@ -4985,7 +5125,7 @@ face for italic. */) for (i = 0; i < LFACE_VECTOR_SIZE; i++) attrs[i] = Qunspecified; - merge_face_ref (f, attributes, attrs, true, 0); + merge_face_ref (NULL, f, attributes, attrs, true, 0); def_face = FACE_FROM_ID_OR_NULL (f, DEFAULT_FACE_ID); if (def_face == NULL) @@ -5354,7 +5494,7 @@ realize_named_face (struct frame *f, Lisp_Object symbol, int id) /* Merge SYMBOL's face with the default face. */ get_lface_attributes_no_remap (f, symbol, symbol_attrs, true); - merge_face_vectors (f, symbol_attrs, attrs, 0); + merge_face_vectors (NULL, f, symbol_attrs, attrs, 0); /* Realize the face. */ realize_face (c, attrs, id); @@ -5869,7 +6009,7 @@ compute_char_face (struct frame *f, int ch, Lisp_Object prop) Lisp_Object attrs[LFACE_VECTOR_SIZE]; struct face *default_face = FACE_FROM_ID (f, DEFAULT_FACE_ID); memcpy (attrs, default_face->lface, sizeof attrs); - merge_face_ref (f, prop, attrs, true, 0); + merge_face_ref (NULL, f, prop, attrs, true, 0); face_id = lookup_face (f, attrs); } @@ -5948,7 +6088,7 @@ face_at_buffer_position (struct window *w, ptrdiff_t pos, else if (NILP (Vface_remapping_alist)) face_id = DEFAULT_FACE_ID; else - face_id = lookup_basic_face (f, DEFAULT_FACE_ID); + face_id = lookup_basic_face (w, f, DEFAULT_FACE_ID); default_face = FACE_FROM_ID (f, face_id); } @@ -5966,7 +6106,7 @@ face_at_buffer_position (struct window *w, ptrdiff_t pos, /* Merge in attributes specified via text properties. */ if (!NILP (prop)) - merge_face_ref (f, prop, attrs, true, 0); + merge_face_ref (w, f, prop, attrs, true, 0); /* Now merge the overlay data. */ noverlays = sort_overlays (overlay_vec, noverlays, w); @@ -5986,7 +6126,7 @@ face_at_buffer_position (struct window *w, ptrdiff_t pos, so discard the mouse-face text property, if any, and use the overlay property instead. */ memcpy (attrs, default_face->lface, sizeof attrs); - merge_face_ref (f, prop, attrs, true, 0); + merge_face_ref (w, f, prop, attrs, true, 0); } oend = OVERLAY_END (overlay_vec[i]); @@ -6004,7 +6144,7 @@ face_at_buffer_position (struct window *w, ptrdiff_t pos, prop = Foverlay_get (overlay_vec[i], propname); if (!NILP (prop)) - merge_face_ref (f, prop, attrs, true, 0); + merge_face_ref (w, f, prop, attrs, true, 0); oend = OVERLAY_END (overlay_vec[i]); oendpos = OVERLAY_POSITION (oend); @@ -6065,12 +6205,12 @@ face_for_overlay_string (struct window *w, ptrdiff_t pos, return DEFAULT_FACE_ID; /* Begin with attributes from the default face. */ - default_face = FACE_FROM_ID (f, lookup_basic_face (f, DEFAULT_FACE_ID)); + default_face = FACE_FROM_ID (f, lookup_basic_face (w, f, DEFAULT_FACE_ID)); memcpy (attrs, default_face->lface, sizeof attrs); /* Merge in attributes specified via text properties. */ if (!NILP (prop)) - merge_face_ref (f, prop, attrs, true, 0); + merge_face_ref (w, f, prop, attrs, true, 0); *endptr = endpos; @@ -6149,7 +6289,7 @@ face_at_string_position (struct window *w, Lisp_Object string, /* Merge in attributes specified via text properties. */ if (!NILP (prop)) - merge_face_ref (f, prop, attrs, true, 0); + merge_face_ref (w, f, prop, attrs, true, 0); /* Look up a realized face with the given face attributes, or realize a new one for ASCII characters. */ @@ -6159,7 +6299,7 @@ face_at_string_position (struct window *w, Lisp_Object string, /* Merge a face into a realized face. - F is frame where faces are (to be) realized. + W is a window in the frame where faces are (to be) realized. FACE_NAME is named face to merge. @@ -6173,9 +6313,10 @@ face_at_string_position (struct window *w, Lisp_Object string, */ int -merge_faces (struct frame *f, Lisp_Object face_name, int face_id, +merge_faces (struct window *w, Lisp_Object face_name, int face_id, int base_face_id) { + struct frame *f = WINDOW_XFRAME (w); Lisp_Object attrs[LFACE_VECTOR_SIZE]; struct face *base_face; @@ -6190,7 +6331,7 @@ merge_faces (struct frame *f, Lisp_Object face_name, int face_id, face_name = lface_id_to_name[face_id]; /* When called during make-frame, lookup_derived_face may fail if the faces are uninitialized. Don't signal an error. */ - face_id = lookup_derived_face (f, face_name, base_face_id, 0); + face_id = lookup_derived_face (w, f, face_name, base_face_id, 0); return (face_id >= 0 ? face_id : base_face_id); } @@ -6199,7 +6340,7 @@ merge_faces (struct frame *f, Lisp_Object face_name, int face_id, if (!NILP (face_name)) { - if (!merge_named_face (f, face_name, attrs, 0)) + if (!merge_named_face (w, f, face_name, attrs, 0)) return base_face_id; } else @@ -6210,7 +6351,7 @@ merge_faces (struct frame *f, Lisp_Object face_name, int face_id, face = FACE_FROM_ID_OR_NULL (f, face_id); if (!face) return base_face_id; - merge_face_vectors (f, face->lface, attrs, 0); + merge_face_vectors (w, f, face->lface, attrs, 0); } /* Look up a realized face with the given face attributes, @@ -6421,6 +6562,11 @@ syms_of_xfaces (void) DEFSYM (Qunspecified, "unspecified"); DEFSYM (QCignore_defface, ":ignore-defface"); + /* Used for limiting character attributes to windows with specific + characteristics. */ + DEFSYM (Qwindow_kw, ":window"); + DEFSYM (Qfiltered_kw, ":filtered"); + /* The symbol `face-alias'. A symbol having that property is an alias for another face. Value of the property is the name of the aliased face. */ @@ -6496,6 +6642,10 @@ syms_of_xfaces (void) defsubr (&Sdump_colors); #endif + DEFVAR_BOOL ("face-filters-always-match", face_filters_always_match, + doc: /* Non-nil means that face filters are always deemed to +match. Use only when evaluating face attributes. */); + DEFVAR_LISP ("face-new-frame-defaults", Vface_new_frame_defaults, doc: /* List of global face definitions (for internal use only.) */); Vface_new_frame_defaults = Qnil; @@ -6544,7 +6694,8 @@ REPLACEMENT is a face specification, i.e. one of the following: (1) a face name (2) a property list of attribute/value pairs, or - (3) a list in which each element has the form of (1) or (2). + (3) + (3) a list in which each element has one of the above forms. List values for REPLACEMENT are merged to form the final face specification, with earlier entries taking precedence, in the same way @@ -6564,13 +6715,32 @@ causes EXTRA-FACE... or (FACE-ATTR VAL ...) to be _merged_ with the existing definition of FACE. Note that this isn't necessary for the default face, since every face inherits from the default face. -If this variable is made buffer-local, the face remapping takes effect -only in that buffer. For instance, the mode my-mode could define a -face `my-mode-default', and then in the mode setup function, do: +An entry in the list can also be a filtered face expression of the +form: + + (:filtered FILTER FACE-SPECIFICATION) + +This construct applies FACE-SPECIFICATION (which can have any of the +forms allowed for face specifications generally) only if FILTER +matches at the moment Emacs wants to draw text with the combined face. + +The only filters currently defined are NIL (which always matches) and +(:window PARAMETER VALUE), which matches only in the context of a +window with a parameter EQ-equal to VALUE. + +An entry in the face list can also be nil, which does nothing. + +If `face-remapping-alist' is made buffer-local, the face remapping +takes effect only in that buffer. For instance, the mode my-mode +could define a face `my-mode-default', and then in the mode setup +function, do: (set (make-local-variable \\='face-remapping-alist) \\='((default my-mode-default)))). +You probably want to use the face-remap package included in Emacs +instead of manipulating face-remapping-alist directly. + Because Emacs normally only redraws screen areas when the underlying buffer contents change, you may need to call `redraw-display' after changing this variable for it to take effect. */); commit e2a98002020369cf0c09c7acf8557290e867705f Author: Paul Eggert Date: Thu Jun 7 18:53:27 2018 -0700 Fit kill_buffer_xwidgets into 80 * src/xwidget.c (kill_buffer_xwidgets): Reindent and use C99 style to fit in 80 columns. diff --git a/src/xwidget.c b/src/xwidget.c index 32022abf34..5f2651214e 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -749,8 +749,10 @@ argument procedure FUN.*/) /* JavaScript execution happens asynchronously. If an elisp callback function is provided we pass it to the C callback procedure that retrieves the return value. */ + gchar *script_string + = XSAVE_POINTER (XCAR (AREF (xw->script_callbacks, idx)), 0); webkit_web_view_run_javascript (WEBKIT_WEB_VIEW (xw->widget_osr), - XSAVE_POINTER (XCAR (AREF (xw->script_callbacks, idx)), 0), + script_string, NULL, /* cancelable */ webkit_javascript_finished_cb, (gpointer) idx); @@ -1221,15 +1223,13 @@ kill_buffer_xwidgets (Lisp_Object buffer) gtk_widget_destroy (xw->widgetwindow_osr); } if (!NILP (xw->script_callbacks)) - { - ptrdiff_t idx; - for (idx = 0; idx < ASIZE (xw->script_callbacks); idx++) - { - if (!NILP (AREF (xw->script_callbacks, idx))) - xfree (XSAVE_POINTER (XCAR (AREF (xw->script_callbacks, idx)), 0)); - ASET (xw->script_callbacks, idx, Qnil); - } - } + for (ptrdiff_t idx = 0; idx < ASIZE (xw->script_callbacks); idx++) + { + Lisp_Object cb = AREF (xw->script_callbacks, idx); + if (!NILP (cb)) + xfree (XSAVE_POINTER (XCAR (cb), 0)); + ASET (xw->script_callbacks, idx, Qnil); + } } } } commit 0e1bfd3886bc8e95fc1b5b13aff565be6caa44e2 Author: Paul Eggert Date: Thu Jun 7 18:53:27 2018 -0700 Minor cleanup of save_excursion_restore * src/editfns.c (save_excursion_restore): Use clearer names for locals. Free earlier, removing the need for a label and goto. diff --git a/src/editfns.c b/src/editfns.c index 2377ceb18a..e672c0eb74 100644 --- a/src/editfns.c +++ b/src/editfns.c @@ -1016,37 +1016,30 @@ save_excursion_save (void) void save_excursion_restore (Lisp_Object info) { - Lisp_Object tem, tem1; - - tem = Fmarker_buffer (XSAVE_OBJECT (info, 0)); + Lisp_Object marker = XSAVE_OBJECT (info, 0); + Lisp_Object window = XSAVE_OBJECT (info, 2); + free_misc (info); + Lisp_Object buffer = Fmarker_buffer (marker); /* If we're unwinding to top level, saved buffer may be deleted. This - means that all of its markers are unchained and so tem is nil. */ - if (NILP (tem)) - goto out; + means that all of its markers are unchained and so BUFFER is nil. */ + if (NILP (buffer)) + return; - Fset_buffer (tem); + Fset_buffer (buffer); - /* Point marker. */ - tem = XSAVE_OBJECT (info, 0); - Fgoto_char (tem); - unchain_marker (XMARKER (tem)); + Fgoto_char (marker); + unchain_marker (XMARKER (marker)); /* If buffer was visible in a window, and a different window was selected, and the old selected window is still showing this buffer, restore point in that window. */ - tem = XSAVE_OBJECT (info, 2); - if (WINDOWP (tem) - && !EQ (tem, selected_window) - && (tem1 = XWINDOW (tem)->contents, - (/* Window is live... */ - BUFFERP (tem1) - /* ...and it shows the current buffer. */ - && XBUFFER (tem1) == current_buffer))) - Fset_window_point (tem, make_number (PT)); - - out: - - free_misc (info); + if (WINDOWP (window) && !EQ (window, selected_window)) + { + /* Set window point if WINDOW is live and shows the current buffer. */ + Lisp_Object contents = XWINDOW (window)->contents; + if (BUFFERP (contents) && XBUFFER (contents) == current_buffer) + Fset_window_point (window, make_number (PT)); + } } DEFUN ("save-excursion", Fsave_excursion, Ssave_excursion, 0, UNEVALLED, 0, commit a0aa1d4ecc123d652285ef10ea62ed55c6c118d6 Author: Paul Eggert Date: Thu Jun 7 18:53:27 2018 -0700 New function record_unwind_protect_excursion This simplifies callers a bit, and will simplify future changes. * src/eval.c (record_unwind_protect_excursion): New function. * src/buffer.c (Fkill_buffer): * src/bytecode.c (exec_byte_code): * src/editfns.c (Fsave_excursion, Freplace_buffer_contents): * src/lread.c (readevalloop, Feval_buffer): * src/window.c (scroll_command): Use it. diff --git a/src/buffer.c b/src/buffer.c index 14837372d3..244c1851fa 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -1696,7 +1696,7 @@ cleaning up all windows currently displaying the buffer to be killed. */) { ptrdiff_t count = SPECPDL_INDEX (); - record_unwind_protect (save_excursion_restore, save_excursion_save ()); + record_unwind_protect_excursion (); set_buffer_internal (b); /* First run the query functions; if any query is answered no, diff --git a/src/bytecode.c b/src/bytecode.c index 55b193ffb2..772cc982f9 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -739,8 +739,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, NEXT; CASE (Bsave_excursion): - record_unwind_protect (save_excursion_restore, - save_excursion_save ()); + record_unwind_protect_excursion (); NEXT; CASE (Bsave_current_buffer): /* Obsolete since ??. */ diff --git a/src/editfns.c b/src/editfns.c index 608304c09a..2377ceb18a 100644 --- a/src/editfns.c +++ b/src/editfns.c @@ -1068,7 +1068,7 @@ usage: (save-excursion &rest BODY) */) register Lisp_Object val; ptrdiff_t count = SPECPDL_INDEX (); - record_unwind_protect (save_excursion_restore, save_excursion_save ()); + record_unwind_protect_excursion (); val = Fprogn (args); return unbind_to (count, val); @@ -3242,7 +3242,7 @@ buffer stay intact. */) Fundo_boundary (); ptrdiff_t count = SPECPDL_INDEX (); - record_unwind_protect (save_excursion_restore, save_excursion_save ()); + record_unwind_protect_excursion (); ptrdiff_t i = size_a; ptrdiff_t j = size_b; diff --git a/src/eval.c b/src/eval.c index 90d8c33518..86011a234c 100644 --- a/src/eval.c +++ b/src/eval.c @@ -3414,6 +3414,12 @@ record_unwind_protect_int (void (*function) (int), int arg) grow_specpdl (); } +void +record_unwind_protect_excursion (void) +{ + record_unwind_protect (save_excursion_restore, save_excursion_save ()); +} + void record_unwind_protect_void (void (*function) (void)) { diff --git a/src/lisp.h b/src/lisp.h index 5b296cd04c..10012b29db 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -3983,6 +3983,7 @@ extern void record_unwind_protect (void (*) (Lisp_Object), Lisp_Object); extern void record_unwind_protect_ptr (void (*) (void *), void *); extern void record_unwind_protect_int (void (*) (int), int); extern void record_unwind_protect_void (void (*) (void)); +extern void record_unwind_protect_excursion (void); extern void record_unwind_protect_nothing (void); extern void clear_unwind_protect (ptrdiff_t); extern void set_unwind_protect (ptrdiff_t, void (*) (Lisp_Object), Lisp_Object); diff --git a/src/lread.c b/src/lread.c index 239c66ccb8..d2c7eae20f 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1976,11 +1976,11 @@ readevalloop (Lisp_Object readcharfun, if (!NILP (start)) { /* Switch to the buffer we are reading from. */ - record_unwind_protect (save_excursion_restore, save_excursion_save ()); + record_unwind_protect_excursion (); set_buffer_internal (b); /* Save point in it. */ - record_unwind_protect (save_excursion_restore, save_excursion_save ()); + record_unwind_protect_excursion (); /* Save ZV in it. */ record_unwind_protect (save_restriction_restore, save_restriction_save ()); /* Those get unbound after we read one expression. */ @@ -2137,7 +2137,7 @@ This function preserves the position of point. */) specbind (Qeval_buffer_list, Fcons (buf, Veval_buffer_list)); specbind (Qstandard_output, tem); - record_unwind_protect (save_excursion_restore, save_excursion_save ()); + record_unwind_protect_excursion (); BUF_TEMP_SET_PT (XBUFFER (buf), BUF_BEGV (XBUFFER (buf))); specbind (Qlexical_binding, lisp_file_lexically_bound_p (buf) ? Qt : Qnil); BUF_TEMP_SET_PT (XBUFFER (buf), BUF_BEGV (XBUFFER (buf))); diff --git a/src/window.c b/src/window.c index f654d87e14..2c6ff01ea4 100644 --- a/src/window.c +++ b/src/window.c @@ -5656,7 +5656,7 @@ scroll_command (Lisp_Object window, Lisp_Object n, int direction) the moment. But don't screw up if window_scroll gets an error. */ if (XBUFFER (w->contents) != current_buffer) { - record_unwind_protect (save_excursion_restore, save_excursion_save ()); + record_unwind_protect_excursion (); Fset_buffer (w->contents); } commit a0641286f6e58f4dca4221caa6dd559bfacea699 Author: Paul Eggert Date: Thu Jun 7 18:53:26 2018 -0700 * src/.gdbinit: Omit soon-obsolete comment. diff --git a/src/.gdbinit b/src/.gdbinit index 7a0cf02ea1..67dcf718e3 100644 --- a/src/.gdbinit +++ b/src/.gdbinit @@ -1020,9 +1020,6 @@ define xpr if $misc == Lisp_Misc_Overlay xoverlay end -# if $misc == Lisp_Misc_Save_Value -# xsavevalue -# end end if $type == Lisp_Vectorlike set $size = ((struct Lisp_Vector *) $ptr)->header.size commit 4d176b742774670c5c265a06f742e63a43f5f7ab Author: Paul Eggert Date: Thu Jun 7 18:53:26 2018 -0700 Fix ftfont_open2 failure cleanup * src/ftfont.c (ftfont_open2): Don’t increment counter if failing. Avoid use-after-free once the increment bug is fixed. diff --git a/src/ftfont.c b/src/ftfont.c index 9a8777ef07..a53467000f 100644 --- a/src/ftfont.c +++ b/src/ftfont.c @@ -1131,16 +1131,19 @@ ftfont_open2 (struct frame *f, return Qnil; } } - set_save_integer (val, 1, XSAVE_INTEGER (val, 1) + 1); size = XINT (AREF (entity, FONT_SIZE_INDEX)); if (size == 0) size = pixel_size; if (FT_Set_Pixel_Sizes (ft_face, size, size) != 0) { if (XSAVE_INTEGER (val, 1) == 0) - FT_Done_Face (ft_face); + { + FT_Done_Face (ft_face); + cache_data->ft_face = NULL; + } return Qnil; } + set_save_integer (val, 1, XSAVE_INTEGER (val, 1) + 1); ASET (font_object, FONT_FILE_INDEX, filename); font = XFONT_OBJECT (font_object); commit b76389f22070bb61811eeea41635640d31115fd9 Author: Paul Eggert Date: Thu Jun 7 18:53:26 2018 -0700 Don’t over-align if WIDE_EMACS_INT * src/lisp.h (GCALIGNED_UNION): New macro. (struct Lisp_Symbol, union vectorlike_header) (struct Lisp_Cons, struct Lisp_String): Use it to avoid possible over-alignment if !USE_LSB_TAG. diff --git a/src/lisp.h b/src/lisp.h index c5af4fa6c7..5b296cd04c 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -229,7 +229,7 @@ extern bool suppress_checking EXTERNALLY_VISIBLE; USE_LSB_TAG not only requires the least 3 bits of pointers returned by malloc to be 0 but also needs to be able to impose a mult-of-8 alignment on some non-GC Lisp_Objects, all of which are aligned via - 'char alignas (GCALIGNMENT) gcaligned;' inside a union. */ + GCALIGNED_UNION at the end of a union. */ enum Lisp_Bits { @@ -277,6 +277,12 @@ DEFINE_GDB_SYMBOL_END (VALMASK) error !; #endif +#if USE_LSB_TAG +# define GCALIGNED_UNION char alignas (GCALIGNMENT) gcaligned; +#else +# define GCALIGNED_UNION +#endif + /* Lisp_Word is a scalar word suitable for holding a tagged pointer or integer. Usually it is a pointer to a deliberately-incomplete type 'union Lisp_X'. However, it is EMACS_INT when Lisp_Objects and @@ -776,7 +782,7 @@ struct Lisp_Symbol /* Next symbol in obarray bucket, if the symbol is interned. */ struct Lisp_Symbol *next; } s; - char alignas (GCALIGNMENT) gcaligned; + GCALIGNED_UNION } u; }; verify (alignof (struct Lisp_Symbol) % GCALIGNMENT == 0); @@ -890,7 +896,7 @@ union vectorlike_header Current layout limits the pseudovectors to 63 PVEC_xxx subtypes, 4095 Lisp_Objects in GC-ed area and 4095 word-sized other slots. */ ptrdiff_t size; - char alignas (GCALIGNMENT) gcaligned; + GCALIGNED_UNION }; verify (alignof (union vectorlike_header) % GCALIGNMENT == 0); @@ -1250,7 +1256,7 @@ struct Lisp_Cons struct Lisp_Cons *chain; } u; } s; - char alignas (GCALIGNMENT) gcaligned; + GCALIGNED_UNION } u; }; verify (alignof (struct Lisp_Cons) % GCALIGNMENT == 0); @@ -1372,7 +1378,7 @@ struct Lisp_String unsigned char *data; } s; struct Lisp_String *next; - char alignas (GCALIGNMENT) gcaligned; + GCALIGNED_UNION } u; }; verify (alignof (struct Lisp_String) % GCALIGNMENT == 0); commit 7c16392ccae50fe09ca3cbb11cc2cd59e5c376cc Author: Paul Eggert Date: Thu Jun 7 18:53:26 2018 -0700 Fix GC-related commentary * src/lisp.h: USE_STACK_LISP_OBJECTS is no longer experimental. Also, remove confusion about scope vs lifetime. And say that stack-allocated strings should not be given text properties. diff --git a/src/lisp.h b/src/lisp.h index ee2e72d32b..c5af4fa6c7 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -228,7 +228,7 @@ extern bool suppress_checking EXTERNALLY_VISIBLE; USE_LSB_TAG not only requires the least 3 bits of pointers returned by malloc to be 0 but also needs to be able to impose a mult-of-8 alignment - on the few static Lisp_Objects used, all of which are aligned via + on some non-GC Lisp_Objects, all of which are aligned via 'char alignas (GCALIGNMENT) gcaligned;' inside a union. */ enum Lisp_Bits @@ -4680,13 +4680,14 @@ extern void *record_xmalloc (size_t) ATTRIBUTE_ALLOC_SIZE ((1)); #define SAFE_ALLOCA_LISP(buf, nelt) SAFE_ALLOCA_LISP_EXTRA (buf, nelt, 0) -/* If USE_STACK_LISP_OBJECTS, define macros that and functions that allocate - block-scoped conses and strings. These objects are not - managed by the garbage collector, so they are dangerous: passing them - out of their scope (e.g., to user code) results in undefined behavior. - Conversely, they have better performance because GC is not involved. +/* If USE_STACK_LISP_OBJECTS, define macros and functions that + allocate some Lisp objects on the C stack. As the storage is not + managed by the garbage collector, these objects are dangerous: + passing them to user code could result in undefined behavior if the + objects are in use after the C function returns. Conversely, these + objects have better performance because GC is not involved. - This feature is experimental and requires careful debugging. + While debugging you may want to disable allocation on the C stack. Build with CPPFLAGS='-DUSE_STACK_LISP_OBJECTS=0' to disable it. */ #if (!defined USE_STACK_LISP_OBJECTS \ @@ -4751,7 +4752,8 @@ enum Take its unibyte value from the null-terminated string STR, an expression that should not have side effects. STR's value is not necessarily copied. The resulting Lisp string - should not be modified or made visible to user code. */ + should not be modified or given text properties or made visible to + user code. */ #define AUTO_STRING(name, str) \ AUTO_STRING_WITH_LEN (name, str, strlen (str)) @@ -4760,7 +4762,8 @@ enum Take its unibyte value from the null-terminated string STR with length LEN. STR may have side effects and may contain null bytes. STR's value is not necessarily copied. The resulting Lisp string - should not be modified or made visible to user code. */ + should not be modified or given text properties or made visible to + user code. */ #define AUTO_STRING_WITH_LEN(name, str, len) \ Lisp_Object name = \ commit 9966842a2166d42cb6969b6bbc5154960d1252bc Author: Noam Postavsky Date: Tue Jun 5 21:07:19 2018 -0400 Let isearch-yank-kill enable isearch-mode if needed (Bug#21419) * lisp/isearch.el (isearch-yank-kill): Enable isearch-mode if needed. diff --git a/lisp/isearch.el b/lisp/isearch.el index feadf10e8b..1e785a44c5 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el @@ -2036,6 +2036,7 @@ If search string is empty, just beep." (defun isearch-yank-kill () "Pull string from kill ring into search string." (interactive) + (unless isearch-mode (isearch-mode t)) (isearch-yank-string (current-kill 0))) (defun isearch-yank-pop () commit 3509aaaefe1996ea46b038850629b6d2f7a726fe Author: João Távora Date: Sat Jun 2 00:23:38 2018 +0100 Accept plists when serializing and parsing JSON * doc/lispref/text.texi (Parsing JSON): Mention plist support. * src/json.c (lisp_to_json_toplevel_1): Serialize plists to json. (Fjson_serialize): Mention plists in docstring. (enum json_object_type): Add json_object_plist. (json_to_lisp): Parse JSON into plists. (json_parse_object_type): Consider plists. (Fjson_parse_string): Mention plists in docstring. (syms_of_json): New Qplist sym_of_json. (lisp_to_json): Update comment. * test/src/json-tests.el (json-serialize/object) (json-parse-string/object): New plist tests. diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi index 2afcd59a70..2c5b5a1b42 100644 --- a/doc/lispref/text.texi +++ b/doc/lispref/text.texi @@ -5026,16 +5026,18 @@ represented using Lisp vectors. @item JSON has only one map type, the object. JSON objects are represented -using Lisp hashtables or alists. When an alist contains several -elements with the same key, Emacs uses only the first element for -serialization, in accordance with the behavior of @code{assq}. +using Lisp hashtables, alists or plists. When an alist or plist +contains several elements with the same key, Emacs uses only the first +element for serialization, in accordance with the behavior of +@code{assq}. @end itemize @noindent -Note that @code{nil} is a valid alist and represents the empty JSON -object, @code{@{@}}, not @code{null}, @code{false}, or an empty array, -all of which are different JSON values. +Note that @code{nil}, being both a valid alist and a valid plist, +represents @code{@{@}}, the empty JSON object; not @code{null}, +@code{false}, or an empty array, all of which are different JSON +values. If some Lisp object can't be represented in JSON, the serialization functions will signal an error of type @code{wrong-type-argument}. @@ -5058,12 +5060,15 @@ The parsing functions will signal the following errors: Only top-level values (arrays and objects) can be serialized to JSON. The subobjects within these top-level values can be of any type. Likewise, the parsing functions will only return vectors, -hashtables, and alists. +hashtables, alists, and plists. The parsing functions accept keyword arguments. Currently only one -keyword argument, @code{:object-type}, is recognized; its value can be -either @code{hash-table} to parse JSON objects as hashtables with -string keys (the default) or @code{alist} to parse them as alists. +keyword argument, @code{:object-type}, is recognized; its value +decides which Lisp object to use for representing the key-value +mappings of a JSON object. It can be either @code{hash-table}, the +default, to make hashtables with strings as keys, @code{alist} to use +alists with symbols as keys or @code{plist} to use plists with keyword +symbols as keys. @defun json-serialize object This function returns a new Lisp string which contains the JSON diff --git a/src/json.c b/src/json.c index b046d34f66..afb81587a4 100644 --- a/src/json.c +++ b/src/json.c @@ -393,18 +393,39 @@ lisp_to_json_toplevel_1 (Lisp_Object lisp, json_t **json) *json = json_check (json_object ()); ptrdiff_t count = SPECPDL_INDEX (); record_unwind_protect_ptr (json_release_object, *json); + bool is_plist = !CONSP (XCAR (tail)); FOR_EACH_TAIL (tail) { - Lisp_Object pair = XCAR (tail); - CHECK_CONS (pair); - Lisp_Object key_symbol = XCAR (pair); - Lisp_Object value = XCDR (pair); + const char *key_str; + Lisp_Object value; + Lisp_Object key_symbol; + if (is_plist) + { + key_symbol = XCAR (tail); + tail = XCDR (tail); + CHECK_CONS (tail); + value = XCAR (tail); + if (EQ (tail, li.tortoise)) circular_list (lisp); + } + else + { + Lisp_Object pair = XCAR (tail); + CHECK_CONS (pair); + key_symbol = XCAR (pair); + value = XCDR (pair); + } CHECK_SYMBOL (key_symbol); Lisp_Object key = SYMBOL_NAME (key_symbol); /* We can't specify the length, so the string must be null-terminated. */ check_string_without_embedded_nulls (key); - const char *key_str = SSDATA (key); + key_str = SSDATA (key); + /* In plists, ensure leading ":" in keys is stripped. It + will be reconstructed later in `json_to_lisp'.*/ + if (is_plist && ':' == key_str[0] && key_str[1]) + { + key_str = &key_str[1]; + } /* Only add element if key is not already present. */ if (json_object_get (*json, key_str) == NULL) { @@ -423,7 +444,7 @@ lisp_to_json_toplevel_1 (Lisp_Object lisp, json_t **json) /* Convert LISP to a toplevel JSON object (array or object). Signal an error of type `wrong-type-argument' if LISP is not a vector, - hashtable, or alist. */ + hashtable, alist, or plist. */ static json_t * lisp_to_json_toplevel (Lisp_Object lisp) @@ -470,20 +491,21 @@ lisp_to_json (Lisp_Object lisp) return json; } - /* LISP now must be a vector, hashtable, or alist. */ + /* LISP now must be a vector, hashtable, alist, or plist. */ return lisp_to_json_toplevel (lisp); } DEFUN ("json-serialize", Fjson_serialize, Sjson_serialize, 1, 1, NULL, doc: /* Return the JSON representation of OBJECT as a string. -OBJECT must be a vector, hashtable, or alist, and its elements can -recursively contain `:null', `:false', t, numbers, strings, or other -vectors hashtables, and alist. `:null', `:false', and t will be -converted to JSON null, false, and true values, respectively. Vectors -will be converted to JSON arrays, and hashtables and alists to JSON -objects. Hashtable keys must be strings without embedded null -characters and must be unique within each object. Alist keys must be -symbols; if a key is duplicate, the first instance is used. */) +OBJECT must be a vector, hashtable, alist, or plist and its elements +can recursively contain `:null', `:false', t, numbers, strings, or +other vectors hashtables, alists or plists. `:null', `:false', and t +will be converted to JSON null, false, and true values, respectively. +Vectors will be converted to JSON arrays, whereas hashtables, alists +and plists are converted to JSON objects. Hashtable keys must be +strings without embedded null characters and must be unique within +each object. Alist and plist keys must be symbols; if a key is +duplicate, the first instance is used. */) (Lisp_Object object) { ptrdiff_t count = SPECPDL_INDEX (); @@ -605,6 +627,7 @@ OBJECT. */) enum json_object_type { json_object_hashtable, json_object_alist, + json_object_plist }; /* Convert a JSON object to a Lisp object. */ @@ -692,6 +715,28 @@ json_to_lisp (json_t *json, enum json_object_type object_type) result = Fnreverse (result); break; } + case json_object_plist: + { + result = Qnil; + const char *key_str; + json_t *value; + json_object_foreach (json, key_str, value) + { + USE_SAFE_ALLOCA; + ptrdiff_t key_str_len = strlen (key_str); + char *keyword_key_str = SAFE_ALLOCA (1 + key_str_len + 1); + keyword_key_str[0] = ':'; + strcpy (&keyword_key_str[1], key_str); + Lisp_Object key = intern_1 (keyword_key_str, key_str_len + 1); + /* Build the plist as value-key since we're going to + reverse it in the end.*/ + result = Fcons (key, result); + result = Fcons (json_to_lisp (value, object_type), result); + SAFE_FREE (); + } + result = Fnreverse (result); + break; + } default: /* Can't get here. */ emacs_abort (); @@ -721,8 +766,10 @@ json_parse_object_type (ptrdiff_t nargs, Lisp_Object *args) return json_object_hashtable; else if (EQ (value, Qalist)) return json_object_alist; + else if (EQ (value, Qplist)) + return json_object_plist; else - wrong_choice (list2 (Qhash_table, Qalist), value); + wrong_choice (list3 (Qhash_table, Qalist, Qplist), value); } default: wrong_type_argument (Qplistp, Flist (nargs, args)); @@ -733,14 +780,15 @@ DEFUN ("json-parse-string", Fjson_parse_string, Sjson_parse_string, 1, MANY, NULL, doc: /* Parse the JSON STRING into a Lisp object. This is essentially the reverse operation of `json-serialize', which -see. The returned object will be a vector, hashtable, or alist. Its -elements will be `:null', `:false', t, numbers, strings, or further -vectors, hashtables, and alists. If there are duplicate keys in an -object, all but the last one are ignored. If STRING doesn't contain a -valid JSON object, an error of type `json-parse-error' is signaled. -The keyword argument `:object-type' specifies which Lisp type is used -to represent objects; it can be `hash-table' or `alist'. -usage: (json-parse-string STRING &key (OBJECT-TYPE \\='hash-table)) */) +see. The returned object will be a vector, hashtable, alist, or +plist. Its elements will be `:null', `:false', t, numbers, strings, +or further vectors, hashtables, alists, or plists. If there are +duplicate keys in an object, all but the last one are ignored. If +STRING doesn't contain a valid JSON object, an error of type +`json-parse-error' is signaled. The keyword argument `:object-type' +specifies which Lisp type is used to represent objects; it can be +`hash-table', `alist' or `plist'. +usage: (json-parse-string STRING &key (OBJECT-TYPE \\='hash-table)) */) (ptrdiff_t nargs, Lisp_Object *args) { ptrdiff_t count = SPECPDL_INDEX (); @@ -912,6 +960,7 @@ syms_of_json (void) DEFSYM (QCobject_type, ":object-type"); DEFSYM (Qalist, "alist"); + DEFSYM (Qplist, "plist"); defsubr (&Sjson_serialize); defsubr (&Sjson_insert); diff --git a/test/src/json-tests.el b/test/src/json-tests.el index 09067bad8c..7a193545b1 100644 --- a/test/src/json-tests.el +++ b/test/src/json-tests.el @@ -69,7 +69,31 @@ (should-error (json-serialize '((1 . 2))) :type 'wrong-type-argument) (should-error (json-serialize '((a . 1) . b)) :type 'wrong-type-argument) (should-error (json-serialize '#1=((a . 1) . #1#)) :type 'circular-list) - (should-error (json-serialize '(#1=(a #1#))))) + (should-error (json-serialize '(#1=(a #1#)))) + + (should (equal (json-serialize '(:abc [1 2 t] :def :null)) + "{\"abc\":[1,2,true],\"def\":null}")) + (should (equal (json-serialize '(abc [1 2 t] :def :null)) + "{\"abc\":[1,2,true],\"def\":null}")) + (should-error (json-serialize '#1=(:a 1 . #1#)) :type 'circular-list) + (should-error (json-serialize '#1=(:a 1 :b . #1#)) :type 'circular-list) + (should-error (json-serialize '(:foo "bar" (unexpected-alist-key . 1))) + :type 'wrong-type-argument) + (should-error (json-serialize '((abc . "abc") :unexpected-plist-key "key")) + :type 'wrong-type-argument) + (should-error (json-serialize '(:foo bar :odd-numbered)) + :type 'wrong-type-argument) + (should (equal + (json-serialize + (list :detect-hash-table #s(hash-table test equal data ("bla" "ble")) + :detect-alist `((bla . "ble")) + :detect-plist `(:bla "ble"))) + "\ +{\ +\"detect-hash-table\":{\"bla\":\"ble\"},\ +\"detect-alist\":{\"bla\":\"ble\"},\ +\"detect-plist\":{\"bla\":\"ble\"}\ +}"))) (ert-deftest json-serialize/object-with-duplicate-keys () (skip-unless (fboundp 'json-serialize)) @@ -89,7 +113,9 @@ (should (equal (cl-sort (map-pairs actual) #'string< :key #'car) '(("abc" . [9 :false]) ("def" . :null))))) (should (equal (json-parse-string input :object-type 'alist) - '((abc . [9 :false]) (def . :null)))))) + '((abc . [9 :false]) (def . :null)))) + (should (equal (json-parse-string input :object-type 'plist) + '(:abc [9 :false] :def :null))))) (ert-deftest json-parse-string/string () (skip-unless (fboundp 'json-parse-string)) commit 2e2f61efa66b69fbd12c83bbd5370a4be2374f66 Author: Michael Albinus Date: Thu Jun 7 11:16:11 2018 +0200 Remove Tramp "obex" and "synce" methods * doc/misc/tramp.texi (GVFS based methods): Remove `obex' and `synce'. * etc/NEWS: Mention obsolete Tramp "obex" and "synce" methods. * lisp/net/tramp-gvfs.el (tramp-gvfs-methods): Remove "obex" and "synce". (top): Do not add defaults for "obex" and "synce". (tramp-bluez-service, tramp-bluez-interface-manager) (tramp-bluez-interface-adapter) (tramp-bluez-discover-devices-timeout, tramp-bluez-discovery) (tramp-bluez-devices, tramp-hal-service, tramp-hal-path-manager) (tramp-hal-interface-manager, tramp-hal-interface-device) (tramp-bluez-address, tramp-bluez-device) (tramp-bluez-list-devices, tramp-bluez-property-changed) (tramp-bluez-device-found, tramp-bluez-parse-device-names) (tramp-synce-list-devices, tramp-synce-parse-device-names): Remove. (tramp-gvfs-handler-mounted-unmounted) (tramp-gvfs-connection-mounted-p, tramp-gvfs-mount-spec): Do not handle "obex" and "synce". diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index 29626138ae..83585038a8 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -1110,13 +1110,6 @@ Since Google Drive uses cryptic blob file names internally, could produce unexpected behavior in case two files in the same directory have the same @code{display-name}, such a situation must be avoided. -@item @option{obex} -@cindex method @option{obex} -@cindex @option{obex} method - -OBEX is an FTP-like access protocol for cell phones and similar simple -devices. @value{tramp} supports OBEX over Bluetooth. - @item @option{owncloud} @cindex @acronym{GNOME} Online Accounts @cindex method @option{owncloud} @@ -1137,24 +1130,16 @@ This method uses @command{sftp} in order to securely access remote hosts. @command{sftp} is a more secure option for connecting to hosts that for security reasons refuse @command{ssh} connections. -@item @option{synce} -@cindex method @option{synce} -@cindex @option{synce} method - -@option{synce} method allows connecting to MS Windows Mobile devices. -It uses GVFS for mounting remote files and directories via FUSE and -requires the SYNCE-GVFS plugin. - @end table @defopt tramp-gvfs-methods This user option is a list of external methods for GVFS@. By default, this list includes @option{afp}, @option{dav}, @option{davs}, -@option{gdrive}, @option{obex}, @option{owncloud}, @option{sftp} and -@option{synce}. Other methods to include are @option{ftp}, -@option{http}, @option{https} and @option{smb}. These methods are not -intended to be used directly as GVFS based method. Instead, they are -added here for the benefit of @ref{Archive file names}. +@option{gdrive}, @option{owncloud} and @option{sftp}. Other methods +to include are @option{ftp}, @option{http}, @option{https} and +@option{smb}. These methods are not intended to be used directly as +GVFS based method. Instead, they are added here for the benefit of +@ref{Archive file names}. @end defopt diff --git a/etc/NEWS b/etc/NEWS index 01dcb441a7..d6b7485f7f 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -429,6 +429,10 @@ process. It now accepts signals specified either by name or by its number. *** New connection method "owncloud", which allows to access OwnCloud or NextCloud hosted files and directories. ++++ +*** Connection methods "obex" and "synce" are removed, because they +are obsoleted in GVFS. + +++ *** Validated passwords are saved by auth-source backends which support this. diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index f547f84a17..87c0c796b6 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -49,10 +49,7 @@ ;; The user option `tramp-gvfs-methods' contains the list of supported ;; connection methods. Per default, these are "afp", "dav", "davs", -;; "gdrive", "obex", "owncloud", "sftp" and "synce". Note that with -;; "obex" it might be necessary to pair with the other bluetooth -;; device, if it hasn't been done already. There might be also some -;; few seconds delay in discovering available bluetooth devices. +;; "gdrive", "owncloud" and "sftp". ;; "gdrive" and "owncloud" connection methods require a respective ;; account in GNOME Online Accounts, with enabled "Files" service. @@ -83,18 +80,14 @@ ;; request an additional connection method to be supported, please ;; drop me a note. -;; For hostname completion, information is retrieved either from the -;; bluez daemon (for the "obex" method), the hal daemon (for the -;; "synce" method), or from the zeroconf daemon (for the "afp", "dav", -;; "davs", and "sftp" methods). The zeroconf daemon is pre-configured -;; to discover services in the "local" domain. If another domain -;; shall be used for discovering services, the user option -;; `tramp-gvfs-zeroconf-domain' can be set accordingly. +;; For hostname completion, information is retrieved from the zeroconf +;; daemon (for the "afp", "dav", "davs", and "sftp" methods). The +;; zeroconf daemon is pre-configured to discover services in the +;; "local" domain. If another domain shall be used for discovering +;; services, the user option `tramp-gvfs-zeroconf-domain' can be set +;; accordingly. ;; Restrictions: - -;; * The current GVFS implementation does not allow writing on the -;; remote bluetooth device via OBEX. ;; ;; * Two shares of the same SMB server cannot be mounted in parallel. @@ -128,10 +121,10 @@ ;;;###tramp-autoload (defcustom tramp-gvfs-methods - '("afp" "dav" "davs" "gdrive" "obex" "owncloud" "sftp" "synce") + '("afp" "dav" "davs" "gdrive" "owncloud" "sftp") "List of methods for remote files, accessed with GVFS." :group 'tramp - :version "26.1" + :version "27.1" :type '(repeat (choice (const "afp") (const "dav") (const "davs") @@ -139,11 +132,9 @@ (const "gdrive") (const "http") (const "https") - (const "obex") (const "owncloud") (const "sftp") - (const "smb") - (const "synce")))) + (const "smb")))) (defconst tramp-goa-methods '("gdrive" "owncloud") "List of methods which require registration at GNOME Online Accounts.") @@ -162,8 +153,6 @@ `("\\`gdrive\\'" nil ,(match-string 1 user-mail-address))) (add-to-list 'tramp-default-host-alist '("\\`gdrive\\'" nil ,(match-string 2 user-mail-address)))) -;;;###tramp-autoload -(add-to-list 'tramp-default-user-alist '("\\`synce\\'" nil nil)) ;;;###tramp-autoload (defcustom tramp-gvfs-zeroconf-domain "local" @@ -463,132 +452,6 @@ It has been changed in GVFS 1.14.") ;; in order to be compatible with Emacs 24 and 25. (cl-defstruct (tramp-goa-name (:type list) :named) method user host port) -(defconst tramp-bluez-service "org.bluez" - "The well known name of the BLUEZ service.") - -(defconst tramp-bluez-interface-manager "org.bluez.Manager" - "The manager interface of the BLUEZ daemon.") - -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; - -(defconst tramp-bluez-interface-adapter "org.bluez.Adapter" - "The adapter interface of the BLUEZ daemon.") - -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; -;; - -;;;###tramp-autoload -(defcustom tramp-bluez-discover-devices-timeout 60 - "Defines seconds since last bluetooth device discovery before rescanning. -A value of 0 would require an immediate discovery during hostname -completion, nil means to use always cached values for discovered -devices." - :group 'tramp - :version "23.2" - :type '(choice (const nil) integer)) - -(defvar tramp-bluez-discovery nil - "Indicator for a running bluetooth device discovery. -It keeps the timestamp of last discovery.") - -(defvar tramp-bluez-devices nil - "Alist of detected bluetooth devices. -Every entry is a list (NAME ADDRESS).") - -(defconst tramp-hal-service "org.freedesktop.Hal" - "The well known name of the HAL service.") - -(defconst tramp-hal-path-manager "/org/freedesktop/Hal/Manager" - "The object path of the HAL daemon manager.") - -(defconst tramp-hal-interface-manager "org.freedesktop.Hal.Manager" - "The manager interface of the HAL daemon.") - -(defconst tramp-hal-interface-device "org.freedesktop.Hal.Device" - "The device interface of the HAL daemon.") - ;; "gvfs-" utilities have been deprecated in GVFS 1.31.1. We ;; must use "gio " tool instead. (defconst tramp-gvfs-gio-mapping @@ -1675,8 +1538,6 @@ file-notify events." (cadr (assoc "uri" (cadr mount-spec)))))) (when (string-match "^\\(afp\\|smb\\)" method) (setq method (match-string 1 method))) - (when (string-equal "obex" method) - (setq host (tramp-bluez-device host))) (when (and (string-equal "dav" method) (string-equal "true" ssl)) (setq method "davs")) (when (and (string-equal "davs" method) @@ -1766,8 +1627,6 @@ file-notify events." (cadr (assoc "volume" (cadr mount-spec))))))) (when (string-match "^\\(afp\\|smb\\)" method) (setq method (match-string 1 method))) - (when (string-equal "obex" method) - (setq host (tramp-bluez-device host))) (when (and (string-equal "dav" method) (string-equal "true" ssl)) (setq method "davs")) (when (and (string-equal "davs" method) @@ -1776,8 +1635,6 @@ file-notify events." (setq method "owncloud")) (when (string-equal "google-drive" method) (setq method "gdrive")) - (when (and (string-equal "synce" method) (zerop (length user))) - (setq user (or (tramp-file-name-user vec) ""))) (when (and (string-equal "http" method) (stringp uri)) (setq uri (url-generic-parse-url uri) method (url-type uri) @@ -1837,10 +1694,6 @@ It was \"a(say)\", but has changed to \"a{sv})\"." (list (tramp-gvfs-mount-spec-entry "type" "smb-share") (tramp-gvfs-mount-spec-entry "server" host) (tramp-gvfs-mount-spec-entry "share" share))) - ((string-equal "obex" method) - (list (tramp-gvfs-mount-spec-entry "type" method) - (tramp-gvfs-mount-spec-entry - "host" (concat "[" (tramp-bluez-address host) "]")))) ((string-match "^dav\\|^owncloud" method) (list (tramp-gvfs-mount-spec-entry "type" "dav") (tramp-gvfs-mount-spec-entry "host" host) @@ -2139,103 +1992,6 @@ VEC is used only for traces." (tramp-get-connection-property key "Uri" "file:///")))))))))) -;; D-Bus BLUEZ functions. - -(defun tramp-bluez-address (device) - "Return bluetooth device address from a given bluetooth DEVICE name." - (when (stringp device) - (if (string-match tramp-ipv6-regexp device) - (match-string 0 device) - (cadr (assoc device (tramp-bluez-list-devices)))))) - -(defun tramp-bluez-device (address) - "Return bluetooth device name from a given bluetooth device ADDRESS. -ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." - (when (stringp address) - (while (string-match "[][]" address) - (setq address (replace-match "" t t address))) - (let (result) - (dolist (item (tramp-bluez-list-devices) result) - (when (string-match address (cadr item)) - (setq result (car item))))))) - -(defun tramp-bluez-list-devices () - "Return all discovered bluetooth devices as list. -Every entry is a list (NAME ADDRESS). - -If `tramp-bluez-discover-devices-timeout' is an integer, and the last -discovery happened more time before indicated there, a rescan will be -started, which lasts some ten seconds. Otherwise, cached results will -be used." - ;; Reset the scanned devices list if time has passed. - (and (integerp tramp-bluez-discover-devices-timeout) - (integerp tramp-bluez-discovery) - (> (tramp-time-diff (current-time) tramp-bluez-discovery) - tramp-bluez-discover-devices-timeout) - (setq tramp-bluez-devices nil)) - - ;; Rescan if needed. - (unless tramp-bluez-devices - (let ((object-path - (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t - :system tramp-bluez-service "/" - tramp-bluez-interface-manager "DefaultAdapter"))) - (setq tramp-bluez-devices nil - tramp-bluez-discovery t) - (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector nil - :system tramp-bluez-service object-path - tramp-bluez-interface-adapter "StartDiscovery") - (while tramp-bluez-discovery - (read-event nil nil 0.1)))) - (setq tramp-bluez-discovery (current-time)) - (tramp-message tramp-gvfs-dbus-event-vector 10 "%s" tramp-bluez-devices) - tramp-bluez-devices) - -(defun tramp-bluez-property-changed (property value) - "Signal handler for the \"org.bluez.Adapter.PropertyChanged\" signal." - (tramp-message tramp-gvfs-dbus-event-vector 6 "%s %s" property value) - (cond - ((string-equal property "Discovering") - (unless (car value) - ;; "Discovering" FALSE means discovery run has been completed. - ;; We stop it, because we don't need another run. - (setq tramp-bluez-discovery nil) - (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t - :system tramp-bluez-service (dbus-event-path-name last-input-event) - tramp-bluez-interface-adapter "StopDiscovery"))))) - -(when tramp-gvfs-enabled - (dbus-register-signal - :system nil nil tramp-bluez-interface-adapter "PropertyChanged" - 'tramp-bluez-property-changed)) - -(defun tramp-bluez-device-found (device args) - "Signal handler for the \"org.bluez.Adapter.DeviceFound\" signal." - (tramp-message tramp-gvfs-dbus-event-vector 6 "%s %s" device args) - (let ((alias (car (cadr (assoc "Alias" args)))) - (address (car (cadr (assoc "Address" args))))) - ;; Maybe we shall check the device class for being a proper - ;; device, and call also SDP in order to find the obex service. - (add-to-list 'tramp-bluez-devices (list alias address)))) - -(when tramp-gvfs-enabled - (dbus-register-signal - :system nil nil tramp-bluez-interface-adapter "DeviceFound" - 'tramp-bluez-device-found)) - -(defun tramp-bluez-parse-device-names (_ignore) - "Return a list of (nil host) tuples allowed to access." - (mapcar - (lambda (x) (list nil (car x))) - (tramp-bluez-list-devices))) - -;; Add completion function for OBEX method. -(when (and tramp-gvfs-enabled - (member tramp-bluez-service (dbus-list-known-names :system))) - (tramp-set-completion-function - "obex" '((tramp-bluez-parse-device-names "")))) - - ;; D-Bus zeroconf functions. (defun tramp-zeroconf-parse-device-names (service) @@ -2317,41 +2073,6 @@ This uses \"avahi-browse\" in case D-Bus is not enabled in Avahi." (tramp-set-completion-function "smb" '((tramp-gvfs-parse-device-names "_smb._tcp")))))))) - -;; D-Bus SYNCE functions. - -(defun tramp-synce-list-devices () - "Return all discovered synce devices as list. -They are retrieved from the hal daemon." - (let (tramp-synce-devices) - (dolist (device - (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t - :system tramp-hal-service tramp-hal-path-manager - tramp-hal-interface-manager "GetAllDevices")) - (when (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t - :system tramp-hal-service device tramp-hal-interface-device - "PropertyExists" "sync.plugin") - (let ((prop - (with-tramp-dbus-call-method - tramp-gvfs-dbus-event-vector t - :system tramp-hal-service device tramp-hal-interface-device - "GetPropertyString" "pda.pocketpc.name"))) - (unless (member prop tramp-synce-devices) - (push prop tramp-synce-devices))))) - (tramp-message tramp-gvfs-dbus-event-vector 10 "%s" tramp-synce-devices) - tramp-synce-devices)) - -(defun tramp-synce-parse-device-names (_ignore) - "Return a list of (nil host) tuples allowed to access." - (mapcar - (lambda (x) (list nil x)) - (tramp-synce-list-devices))) - -;; Add completion function for SYNCE method. -(when tramp-gvfs-enabled - (tramp-set-completion-function - "synce" '((tramp-synce-parse-device-names "")))) - (add-hook 'tramp-unload-hook (lambda () (unload-feature 'tramp-gvfs 'force))) @@ -2368,11 +2089,6 @@ They are retrieved from the hal daemon." ;; * Check, how two shares of the same SMB server can be mounted in ;; parallel. ;; -;; * Apply SDP on bluetooth devices, in order to filter out obex -;; capability. -;; -;; * Implement obex for other serial communication but bluetooth. -;; ;; * What's up with ftps dns-sd afc admin computer? ;;; tramp-gvfs.el ends here