Now on revision 113286. ------------------------------------------------------------ revno: 113286 committer: Leo Liu branch nick: trunk timestamp: Fri 2013-07-05 10:37:39 +0800 message: * autoinsert.el (auto-insert-alist): Default to lexical-binding. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2013-07-04 10:25:54 +0000 +++ lisp/ChangeLog 2013-07-05 02:37:39 +0000 @@ -1,3 +1,7 @@ +2013-07-05 Leo Liu + + * autoinsert.el (auto-insert-alist): Default to lexical-binding. + 2013-07-04 YAMAMOTO Mitsuharu * frame.el (display-pixel-height, display-pixel-width) === modified file 'lisp/autoinsert.el' --- lisp/autoinsert.el 2013-01-01 09:11:05 +0000 +++ lisp/autoinsert.el 2013-07-05 02:37:39 +0000 @@ -164,7 +164,10 @@ (("\\.el\\'" . "Emacs Lisp header") "Short description: " - ";;; " (file-name-nondirectory (buffer-file-name)) " --- " str " + ";;; " (file-name-nondirectory (buffer-file-name)) " --- " str + (make-string (max 2 (- 80 (current-column) 27)) ?\s) + "-*- lexical-binding: t; -*-" + " ;; Copyright (C) " (format-time-string "%Y") " " (getenv "ORGANIZATION") | (progn user-full-name) " ------------------------------------------------------------ revno: 113285 committer: Glenn Morris branch nick: trunk timestamp: Thu 2013-07-04 18:35:56 -0700 message: * admin/admin.el (make-manuals): Use a standard location for lispintro. diff: === modified file 'admin/ChangeLog' --- admin/ChangeLog 2013-06-29 02:54:37 +0000 +++ admin/ChangeLog 2013-07-05 01:35:56 +0000 @@ -1,3 +1,7 @@ +2013-07-05 Glenn Morris + + * admin.el (make-manuals): Use a standard location for lispintro. + 2013-06-29 Glenn Morris * admin.el (make-manuals): Don't bother with txt or dvi any more. === modified file 'admin/admin.el' --- admin/admin.el 2013-06-29 02:54:37 +0000 +++ admin/admin.el 2013-07-05 01:35:56 +0000 @@ -220,18 +220,12 @@ (manual-html-mono texi (expand-file-name "elisp.html" html-mono-dir)) (manual-pdf texi (expand-file-name "elisp.pdf" dest)) (manual-ps texi (expand-file-name "elisp.ps" ps-dir))) - (let ((texi (expand-file-name "doc/lispintro/emacs-lisp-intro.texi" root)) - (dest (expand-file-name "emacs-lisp-intro" dest)) - dest2) - ;; Mimic the atypical directory layout used for emacs-lisp-intro. - (make-directory dest) - (make-directory (setq dest2 (expand-file-name "html_node" dest))) - (manual-html-node texi dest2) - (make-directory (setq dest2 (expand-file-name "html_mono" dest))) - (manual-html-mono texi (expand-file-name "emacs-lisp-intro.html" dest2)) - (manual-pdf texi (expand-file-name "emacs-lisp-intro.pdf" dest)) - (make-directory (setq dest2 (expand-file-name "ps" dest))) - (manual-ps texi (expand-file-name "emacs-lisp-intro.ps" dest2))) + ;; Lisp intro. + (let ((texi (expand-file-name "doc/lispintro/emacs-lisp-intro.texi" root))) + (manual-html-node texi (expand-file-name "eintr" html-node-dir)) + (manual-html-mono texi (expand-file-name "eintr.html" html-mono-dir)) + (manual-pdf texi (expand-file-name "eintr.pdf" dest)) + (manual-ps texi (expand-file-name "eintr.ps" ps-dir))) ;; Misc manuals (let ((manuals '("ada-mode" "auth" "autotype" "bovine" "calc" "cc-mode" "cl" "dbus" "dired-x" "ebrowse" "ede" "ediff" ------------------------------------------------------------ revno: 113284 committer: Paul Eggert branch nick: trunk timestamp: Thu 2013-07-04 08:25:54 -0700 message: Scale ImageMagick images more carefully. * image.c (scale_image_size) [HAVE_IMAGEMAGICK]: New function. (compute_image_size): Use it. Define only if HAVE_IMAGEMAGICK. Be more careful about avoiding undefined behavior after integer overflow and division by zero. diff: === modified file 'src/ChangeLog' --- src/ChangeLog 2013-07-04 10:25:54 +0000 +++ src/ChangeLog 2013-07-04 15:25:54 +0000 @@ -1,3 +1,11 @@ +2013-07-04 Paul Eggert + + Scale ImageMagick images more carefully. + * image.c (scale_image_size) [HAVE_IMAGEMAGICK]: New function. + (compute_image_size): Use it. Define only if HAVE_IMAGEMAGICK. + Be more careful about avoiding undefined behavior after + integer overflow and division by zero. + 2013-07-04 YAMAMOTO Mitsuharu * w32fns.c (Qgeometry, Qworkarea, Qmm_size, Qframes): New variables. === modified file 'src/image.c' --- src/image.c 2013-07-04 02:08:56 +0000 +++ src/image.c 2013-07-04 15:25:54 +0000 @@ -7625,6 +7625,31 @@ #endif /* HAVE_GIF */ +#ifdef HAVE_IMAGEMAGICK + +/*********************************************************************** + ImageMagick +***********************************************************************/ + +/* Scale an image size by returning SIZE / DIVISOR * MULTIPLIER, + safely rounded and clipped to int range. */ + +static int +scale_image_size (int size, size_t divisor, size_t multiplier) +{ + if (divisor != 0) + { + double s = size; + double scaled = s * multiplier / divisor + 0.5; + if (scaled < INT_MAX) + return scaled; + } + return INT_MAX; +} + +/* Compute the desired size of an image with native size WIDTH x HEIGHT. + Use SPEC to deduce the size. Store the desired size into + *D_WIDTH x *D_HEIGHT. Store -1 x -1 if the native size is OK. */ static void compute_image_size (size_t width, size_t height, Lisp_Object spec, @@ -7638,39 +7663,36 @@ unspecified should be calculated from the specified to preserve aspect ratio. */ value = image_spec_value (spec, QCwidth, NULL); - desired_width = (INTEGERP (value) ? XFASTINT (value) : -1); + desired_width = NATNUMP (value) ? min (XFASTINT (value), INT_MAX) : -1; value = image_spec_value (spec, QCheight, NULL); - desired_height = (INTEGERP (value) ? XFASTINT (value) : -1); + desired_height = NATNUMP (value) ? min (XFASTINT (value), INT_MAX) : -1; if (desired_width == -1) { value = image_spec_value (spec, QCmax_width, NULL); - if (INTEGERP (value) && - width > XFASTINT (value)) + if (NATNUMP (value)) { - /* The image is wider than :max-width. */ - desired_width = XFASTINT (value); - if (desired_height == -1) + int max_width = min (XFASTINT (value), INT_MAX); + if (max_width < width) { - value = image_spec_value (spec, QCmax_height, NULL); - if (INTEGERP (value)) + /* The image is wider than :max-width. */ + desired_width = max_width; + if (desired_height == -1) { - /* We have no specified height, but we have a - :max-height value, so check that we satisfy both - conditions. */ - desired_height = (double) desired_width / width * height; - if (desired_height > XFASTINT (value)) + desired_height = scale_image_size (desired_width, + width, height); + value = image_spec_value (spec, QCmax_height, NULL); + if (NATNUMP (value)) { - desired_height = XFASTINT (value); - desired_width = (double) desired_height / height * width; + int max_height = min (XFASTINT (value), INT_MAX); + if (max_height < desired_height) + { + desired_height = max_height; + desired_width = scale_image_size (desired_height, + height, width); + } } } - else - { - /* We have no specified height and no specified - max-height, so just compute the height. */ - desired_height = (double) desired_width / width * height; - } } } } @@ -7678,28 +7700,26 @@ if (desired_height == -1) { value = image_spec_value (spec, QCmax_height, NULL); - if (INTEGERP (value) && - height > XFASTINT (value)) - desired_height = XFASTINT (value); + if (NATNUMP (value)) + { + int max_height = min (XFASTINT (value), INT_MAX); + if (max_height < height) + desired_height = max_height; + } } if (desired_width != -1 && desired_height == -1) /* w known, calculate h. */ - desired_height = (double) desired_width / width * height; + desired_height = scale_image_size (desired_width, width, height); if (desired_width == -1 && desired_height != -1) /* h known, calculate w. */ - desired_width = (double) desired_height / height * width; + desired_width = scale_image_size (desired_height, height, width); *d_width = desired_width; *d_height = desired_height; } -/*********************************************************************** - ImageMagick -***********************************************************************/ -#if defined (HAVE_IMAGEMAGICK) - static Lisp_Object Qimagemagick; static bool imagemagick_image_p (Lisp_Object); ------------------------------------------------------------ revno: 113283 committer: YAMAMOTO Mitsuharu branch nick: trunk timestamp: Thu 2013-07-04 19:25:54 +0900 message: Add multi-monitor support on W32. diff: === modified file 'etc/NEWS' --- etc/NEWS 2013-07-04 09:40:56 +0000 +++ etc/NEWS 2013-07-04 10:25:54 +0000 @@ -125,6 +125,14 @@ `frame-monitor-attributes' can be used to obtain information about each physical monitor on multi-monitor setups. +*** The functions `display-pixel-width' and `display-pixel-height' now +behave consistently among the platforms: they return the pixel width +or height for all physical monitors associated with the given display +as just they were on X11. To get information for each physical +monitor, use the new functions above. Similar notes also apply to +`x-display-pixel-width', `x-display-pixel-height', `display-mm-width', +`display-mm-height', `x-display-mm-width', and `x-display-mm-height'. + * Editing Changes in Emacs 24.4 === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2013-07-04 09:39:36 +0000 +++ lisp/ChangeLog 2013-07-04 10:25:54 +0000 @@ -1,3 +1,11 @@ +2013-07-04 YAMAMOTO Mitsuharu + + * frame.el (display-pixel-height, display-pixel-width) + (display-mm-height, display-mm-width): Mention behavior on + multi-monitor setups in docstrings. + (w32-display-monitor-attributes-list): Declare function. + (display-monitor-attributes-list): Use it. + 2013-07-04 Michael Albinus * filenotify.el: New package. === modified file 'lisp/frame.el' --- lisp/frame.el 2013-05-11 02:27:28 +0000 +++ lisp/frame.el 2013-07-04 10:25:54 +0000 @@ -1365,7 +1365,11 @@ (defun display-pixel-height (&optional display) "Return the height of DISPLAY's screen in pixels. -For character terminals, each character counts as a single pixel." +For character terminals, each character counts as a single pixel. +For graphical terminals, note that on \"multi-monitor\" setups this +refers to the pixel height for all physical monitors associated +with DISPLAY. To get information for each physical monitor, use +`display-monitor-attributes-list'." (let ((frame-type (framep-on-display display))) (cond ((memq frame-type '(x w32 ns)) @@ -1377,7 +1381,11 @@ (defun display-pixel-width (&optional display) "Return the width of DISPLAY's screen in pixels. -For character terminals, each character counts as a single pixel." +For character terminals, each character counts as a single pixel. +For graphical terminals, note that on \"multi-monitor\" setups this +refers to the pixel width for all physical monitors associated +with DISPLAY. To get information for each physical monitor, use +`display-monitor-attributes-list'." (let ((frame-type (framep-on-display display))) (cond ((memq frame-type '(x w32 ns)) @@ -1408,7 +1416,11 @@ (defun display-mm-height (&optional display) "Return the height of DISPLAY's screen in millimeters. System values can be overridden by `display-mm-dimensions-alist'. -If the information is unavailable, value is nil." +If the information is unavailable, value is nil. +For graphical terminals, note that on \"multi-monitor\" setups this +refers to the height in millimeters for all physical monitors +associated with DISPLAY. To get information for each physical +monitor, use `display-monitor-attributes-list'." (and (memq (framep-on-display display) '(x w32 ns)) (or (cddr (assoc (or display (frame-parameter nil 'display)) display-mm-dimensions-alist)) @@ -1420,7 +1432,11 @@ (defun display-mm-width (&optional display) "Return the width of DISPLAY's screen in millimeters. System values can be overridden by `display-mm-dimensions-alist'. -If the information is unavailable, value is nil." +If the information is unavailable, value is nil. +For graphical terminals, note that on \"multi-monitor\" setups this +refers to the width in millimeters for all physical monitors +associated with DISPLAY. To get information for each physical +monitor, use `display-monitor-attributes-list'." (and (memq (framep-on-display display) '(x w32 ns)) (or (cadr (assoc (or display (frame-parameter nil 'display)) display-mm-dimensions-alist)) @@ -1495,6 +1511,8 @@ (declare-function x-display-monitor-attributes-list "xfns.c" (&optional terminal)) +(declare-function w32-display-monitor-attributes-list "w32fns.c" + (&optional display)) (declare-function ns-display-monitor-attributes-list "nsfns.m" (&optional terminal)) @@ -1530,6 +1548,8 @@ (cond ((eq frame-type 'x) (x-display-monitor-attributes-list display)) + ((eq frame-type 'w32) + (w32-display-monitor-attributes-list display)) ((eq frame-type 'ns) (ns-display-monitor-attributes-list display)) (t === modified file 'src/ChangeLog' --- src/ChangeLog 2013-07-04 09:29:28 +0000 +++ src/ChangeLog 2013-07-04 10:25:54 +0000 @@ -1,3 +1,27 @@ +2013-07-04 YAMAMOTO Mitsuharu + + * w32fns.c (Qgeometry, Qworkarea, Qmm_size, Qframes): New variables. + (syms_of_w32fns): DEFSYM them. + (MONITORINFOF_PRIMARY, SM_XVIRTUALSCREEN, SM_YVIRTUALSCREEN) + (CCHDEVICENAME): Define macros if not defined. + (struct MONITOR_INFO_EX): New struct. + (MonitorEnum_Proc, EnumDisplayMonitors_Proc): New prototypes. + (enum_display_monitors_fn): New variable. + (globals_of_w32fns): Initialize it. + (Fx_display_pixel_width, Fx_display_pixel_height) + (Fx_display_mm_height, Fx_display_mm_width): Mention behavior on + multi-monitor setups in docstrings. + (Fx_display_mm_height, Fx_display_mm_width): Approximate whole + screen size by primary monitor's millimeter per pixel. + (w32_monitor_enum, w32_display_monitor_attributes_list) + (w32_display_monitor_attributes_list_fallback) + (Fw32_display_monitor_attributes_list): New functions. + (syms_of_w32fns): Defsubr Sw32_display_monitor_attributes_list. + + * w32term.c (SM_CXVIRTUALSCREEN, SM_CYVIRTUALSCREEN): Define macros + if not defined. + (x_display_pixel_height, x_display_pixel_width): Use GetSystemMetrics. + 2013-07-04 Michael Albinus * fileio.c (Qfile_notify_error): New error symbol. === modified file 'src/w32fns.c' --- src/w32fns.c 2013-06-20 17:36:24 +0000 +++ src/w32fns.c 2013-07-04 10:25:54 +0000 @@ -106,6 +106,7 @@ Lisp_Object Qctrl; Lisp_Object Qcontrol; Lisp_Object Qshift; +static Lisp_Object Qgeometry, Qworkarea, Qmm_size, Qframes; /* Prefix for system colors. */ @@ -131,6 +132,15 @@ #ifndef MONITOR_DEFAULT_TO_NEAREST #define MONITOR_DEFAULT_TO_NEAREST 2 #endif +#ifndef MONITORINFOF_PRIMARY +#define MONITORINFOF_PRIMARY 1 +#endif +#ifndef SM_XVIRTUALSCREEN +#define SM_XVIRTUALSCREEN 76 +#endif +#ifndef SM_YVIRTUALSCREEN +#define SM_YVIRTUALSCREEN 77 +#endif /* MinGW headers define MONITORINFO unconditionally, but MSVC ones don't. To avoid a compile error on one or the other, redefine with a new name. */ struct MONITOR_INFO @@ -141,6 +151,18 @@ DWORD dwFlags; }; +#ifndef CCHDEVICENAME +#define CCHDEVICENAME 32 +#endif +struct MONITOR_INFO_EX +{ + DWORD cbSize; + RECT rcMonitor; + RECT rcWork; + DWORD dwFlags; + char szDevice[CCHDEVICENAME]; +}; + /* Reportedly, MSVC does not have this in its headers. */ #if defined (_MSC_VER) && _WIN32_WINNT < 0x0500 DECLARE_HANDLE(HMONITOR); @@ -159,6 +181,10 @@ (IN HMONITOR monitor, OUT struct MONITOR_INFO* info); typedef HMONITOR (WINAPI * MonitorFromWindow_Proc) (IN HWND hwnd, IN DWORD dwFlags); +typedef BOOL CALLBACK (* MonitorEnum_Proc) + (IN HMONITOR monitor, IN HDC hdc, IN RECT *rcMonitor, IN LPARAM dwData); +typedef BOOL (WINAPI * EnumDisplayMonitors_Proc) + (IN HDC hdc, IN RECT *rcClip, IN MonitorEnum_Proc fnEnum, IN LPARAM dwData); TrackMouseEvent_Proc track_mouse_event_fn = NULL; ImmGetCompositionString_Proc get_composition_string_fn = NULL; @@ -168,6 +194,7 @@ MonitorFromPoint_Proc monitor_from_point_fn = NULL; GetMonitorInfo_Proc get_monitor_info_fn = NULL; MonitorFromWindow_Proc monitor_from_window_fn = NULL; +EnumDisplayMonitors_Proc enum_display_monitors_fn = NULL; #ifdef NTGUI_UNICODE #define unicode_append_menu AppendMenuW @@ -4674,7 +4701,11 @@ doc: /* Return the width in pixels of DISPLAY. The optional argument DISPLAY specifies which display to ask about. DISPLAY should be either a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display. */) +If omitted or nil, that stands for the selected frame's display. + +On \"multi-monitor\" setups this refers to the pixel width for all +physical monitors associated with DISPLAY. To get information for +each physical monitor, use `display-monitor-attributes-list'. */) (Lisp_Object display) { struct w32_display_info *dpyinfo = check_x_display_info (display); @@ -4687,7 +4718,11 @@ doc: /* Return the height in pixels of DISPLAY. The optional argument DISPLAY specifies which display to ask about. DISPLAY should be either a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display. */) +If omitted or nil, that stands for the selected frame's display. + +On \"multi-monitor\" setups this refers to the pixel height for all +physical monitors associated with DISPLAY. To get information for +each physical monitor, use `display-monitor-attributes-list'. */) (Lisp_Object display) { struct w32_display_info *dpyinfo = check_x_display_info (display); @@ -4779,41 +4814,46 @@ doc: /* Return the height in millimeters of DISPLAY. The optional argument DISPLAY specifies which display to ask about. DISPLAY should be either a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display. */) +If omitted or nil, that stands for the selected frame's display. + +On \"multi-monitor\" setups this refers to the height in millimeters for +all physical monitors associated with DISPLAY. To get information +for each physical monitor, use `display-monitor-attributes-list'. */) (Lisp_Object display) { struct w32_display_info *dpyinfo = check_x_display_info (display); HDC hdc; - int cap; - - hdc = GetDC (dpyinfo->root_window); - - cap = GetDeviceCaps (hdc, VERTSIZE); - - ReleaseDC (dpyinfo->root_window, hdc); - - return make_number (cap); + double mm_per_pixel; + + hdc = GetDC (NULL); + mm_per_pixel = ((double) GetDeviceCaps (hdc, VERTSIZE) + / GetDeviceCaps (hdc, VERTRES)); + ReleaseDC (NULL, hdc); + + return make_number (x_display_pixel_height (dpyinfo) * mm_per_pixel + 0.5); } DEFUN ("x-display-mm-width", Fx_display_mm_width, Sx_display_mm_width, 0, 1, 0, doc: /* Return the width in millimeters of DISPLAY. The optional argument DISPLAY specifies which display to ask about. DISPLAY should be either a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display. */) +If omitted or nil, that stands for the selected frame's display. + +On \"multi-monitor\" setups this refers to the width in millimeters for +all physical monitors associated with TERMINAL. To get information +for each physical monitor, use `display-monitor-attributes-list'. */) (Lisp_Object display) { struct w32_display_info *dpyinfo = check_x_display_info (display); - HDC hdc; - int cap; - - hdc = GetDC (dpyinfo->root_window); - - cap = GetDeviceCaps (hdc, HORZSIZE); - - ReleaseDC (dpyinfo->root_window, hdc); - - return make_number (cap); + double mm_per_pixel; + + hdc = GetDC (NULL); + mm_per_pixel = ((double) GetDeviceCaps (hdc, HORZSIZE) + / GetDeviceCaps (hdc, HORZRES)); + ReleaseDC (NULL, hdc); + + return make_number (x_display_pixel_width (dpyinfo) * mm_per_pixel + 0.5); } DEFUN ("x-display-backing-store", Fx_display_backing_store, @@ -4865,6 +4905,202 @@ return Qnil; } +static BOOL CALLBACK +w32_monitor_enum (HMONITOR monitor, HDC hdc, RECT *rcMonitor, LPARAM dwData) +{ + Lisp_Object *monitor_list = (Lisp_Object *) dwData; + + *monitor_list = Fcons (make_save_pointer (monitor), *monitor_list); + + return TRUE; +} + +static Lisp_Object +w32_display_monitor_attributes_list (void) +{ + Lisp_Object attributes_list = Qnil, primary_monitor_attributes = Qnil; + Lisp_Object monitor_list = Qnil, monitor_frames, rest, frame; + int i, n_monitors; + HMONITOR *monitors; + struct gcpro gcpro1, gcpro2, gcpro3; + + if (!(enum_display_monitors_fn && get_monitor_info_fn + && monitor_from_window_fn)) + return Qnil; + + if (!enum_display_monitors_fn (NULL, NULL, w32_monitor_enum, + (LPARAM) &monitor_list) + || NILP (monitor_list)) + return Qnil; + + n_monitors = 0; + for (rest = monitor_list; CONSP (rest); rest = XCDR (rest)) + n_monitors++; + + monitors = xmalloc (n_monitors * sizeof (*monitors)); + for (i = 0; i < n_monitors; i++) + { + monitors[i] = XSAVE_POINTER (XCAR (monitor_list), 0); + monitor_list = XCDR (monitor_list); + } + + monitor_frames = Fmake_vector (make_number (n_monitors), Qnil); + FOR_EACH_FRAME (rest, frame) + { + struct frame *f = XFRAME (frame); + + if (FRAME_W32_P (f) && !EQ (frame, tip_frame)) + { + HMONITOR monitor = + monitor_from_window_fn (FRAME_W32_WINDOW (f), + MONITOR_DEFAULT_TO_NEAREST); + + for (i = 0; i < n_monitors; i++) + if (monitors[i] == monitor) + break; + + if (i < n_monitors) + ASET (monitor_frames, i, Fcons (frame, AREF (monitor_frames, i))); + } + } + + GCPRO3 (attributes_list, primary_monitor_attributes, monitor_frames); + + for (i = 0; i < n_monitors; i++) + { + Lisp_Object geometry, workarea, name, attributes = Qnil; + HDC hdc; + int width_mm, height_mm; + struct MONITOR_INFO_EX mi; + + mi.cbSize = sizeof (mi); + if (!get_monitor_info_fn (monitors[i], (struct MONITOR_INFO *) &mi)) + continue; + + hdc = CreateDCA ("DISPLAY", mi.szDevice, NULL, NULL); + if (hdc == NULL) + continue; + width_mm = GetDeviceCaps (hdc, HORZSIZE); + height_mm = GetDeviceCaps (hdc, VERTSIZE); + DeleteDC (hdc); + + attributes = Fcons (Fcons (Qframes, AREF (monitor_frames, i)), + attributes); + + name = DECODE_SYSTEM (make_unibyte_string (mi.szDevice, + strlen (mi.szDevice))); + attributes = Fcons (Fcons (Qname, name), attributes); + + attributes = Fcons (Fcons (Qmm_size, list2i (width_mm, height_mm)), + attributes); + + workarea = list4i (mi.rcWork.left, mi.rcWork.top, + mi.rcWork.right - mi.rcWork.left, + mi.rcWork.bottom - mi.rcWork.top); + attributes = Fcons (Fcons (Qworkarea, workarea), attributes); + + geometry = list4i (mi.rcMonitor.left, mi.rcMonitor.top, + mi.rcMonitor.right - mi.rcMonitor.left, + mi.rcMonitor.bottom - mi.rcMonitor.top); + attributes = Fcons (Fcons (Qgeometry, geometry), attributes); + + if (mi.dwFlags & MONITORINFOF_PRIMARY) + primary_monitor_attributes = attributes; + else + attributes_list = Fcons (attributes, attributes_list); + } + + if (!NILP (primary_monitor_attributes)) + attributes_list = Fcons (primary_monitor_attributes, attributes_list); + + UNGCPRO; + + xfree (monitors); + + return attributes_list; +} + +static Lisp_Object +w32_display_monitor_attributes_list_fallback (struct w32_display_info *dpyinfo) +{ + Lisp_Object geometry, workarea, frames, rest, frame, attributes = Qnil; + HDC hdc; + double mm_per_pixel; + int pixel_width, pixel_height, width_mm, height_mm; + RECT workarea_rect; + + /* Fallback: treat (possibly) multiple physical monitors as if they + formed a single monitor as a whole. This should provide a + consistent result at least on single monitor environments. */ + attributes = Fcons (Fcons (Qname, build_string ("combined screen")), + attributes); + + frames = Qnil; + FOR_EACH_FRAME (rest, frame) + { + struct frame *f = XFRAME (frame); + + if (FRAME_W32_P (f) && !EQ (frame, tip_frame)) + frames = Fcons (frame, frames); + } + attributes = Fcons (Fcons (Qframes, frames), attributes); + + pixel_width = x_display_pixel_width (dpyinfo); + pixel_height = x_display_pixel_height (dpyinfo); + + hdc = GetDC (NULL); + mm_per_pixel = ((double) GetDeviceCaps (hdc, HORZSIZE) + / GetDeviceCaps (hdc, HORZRES)); + width_mm = pixel_width * mm_per_pixel + 0.5; + mm_per_pixel = ((double) GetDeviceCaps (hdc, VERTSIZE) + / GetDeviceCaps (hdc, VERTRES)); + height_mm = pixel_height * mm_per_pixel + 0.5; + ReleaseDC (NULL, hdc); + attributes = Fcons (Fcons (Qmm_size, list2i (width_mm, height_mm)), + attributes); + + /* GetSystemMetrics below may return 0 for Windows 95 or NT 4.0, but + we don't care. */ + geometry = list4i (GetSystemMetrics (SM_XVIRTUALSCREEN), + GetSystemMetrics (SM_YVIRTUALSCREEN), + pixel_width, pixel_height); + if (SystemParametersInfo (SPI_GETWORKAREA, 0, &workarea_rect, 0)) + workarea = list4i (workarea_rect.left, workarea_rect.top, + workarea_rect.right - workarea_rect.left, + workarea_rect.bottom - workarea_rect.top); + else + workarea = geometry; + attributes = Fcons (Fcons (Qworkarea, workarea), attributes); + + attributes = Fcons (Fcons (Qgeometry, geometry), attributes); + + return list1 (attributes); +} + +DEFUN ("w32-display-monitor-attributes-list", Fw32_display_monitor_attributes_list, + Sw32_display_monitor_attributes_list, + 0, 1, 0, + doc: /* Return a list of physical monitor attributes on the W32 display DISPLAY. + +The optional argument DISPLAY specifies which display to ask about. +DISPLAY should be either a frame or a display name (a string). +If omitted or nil, that stands for the selected frame's display. + +Internal use only, use `display-monitor-attributes-list' instead. */) + (Lisp_Object display) +{ + struct w32_display_info *dpyinfo = check_x_display_info (display); + Lisp_Object attributes_list; + + block_input (); + attributes_list = w32_display_monitor_attributes_list (); + if (NILP (attributes_list)) + attributes_list = w32_display_monitor_attributes_list_fallback (dpyinfo); + unblock_input (); + + return attributes_list; +} + DEFUN ("set-message-beep", Fset_message_beep, Sset_message_beep, 1, 1, 0, doc: /* Set the sound generated when the bell is rung. SOUND is 'asterisk, 'exclamation, 'hand, 'question, 'ok, or 'silent @@ -7357,6 +7593,10 @@ DEFSYM (Qcontrol, "control"); DEFSYM (Qshift, "shift"); DEFSYM (Qfont_param, "font-parameter"); + DEFSYM (Qgeometry, "geometry"); + DEFSYM (Qworkarea, "workarea"); + DEFSYM (Qmm_size, "mm-size"); + DEFSYM (Qframes, "frames"); /* This is the end of symbol initialization. */ @@ -7646,6 +7886,7 @@ defsubr (&Sw32_define_rgb_color); defsubr (&Sw32_default_color_map); + defsubr (&Sw32_display_monitor_attributes_list); defsubr (&Sw32_send_sys_command); defsubr (&Sw32_shell_execute); defsubr (&Sw32_register_hot_key); @@ -7707,6 +7948,8 @@ GetProcAddress (user32_lib, "GetMonitorInfoA"); monitor_from_window_fn = (MonitorFromWindow_Proc) GetProcAddress (user32_lib, "MonitorFromWindow"); + enum_display_monitors_fn = (EnumDisplayMonitors_Proc) + GetProcAddress (user32_lib, "EnumDisplayMonitors"); { HMODULE imm32_lib = GetModuleHandle ("imm32.dll"); === modified file 'src/w32term.c' --- src/w32term.c 2013-06-20 17:36:24 +0000 +++ src/w32term.c 2013-07-04 10:25:54 +0000 @@ -143,6 +143,15 @@ #define WS_EX_LAYERED 0x80000 #endif +/* SM_CXVIRTUALSCREEN and SM_CYVIRTUALSCREEN are not defined on 95 and + NT4. */ +#ifndef SM_CXVIRTUALSCREEN +#define SM_CXVIRTUALSCREEN 78 +#endif +#ifndef SM_CYVIRTUALSCREEN +#define SM_CYVIRTUALSCREEN 79 +#endif + /* This is a frame waiting to be autoraised, within w32_read_socket. */ struct frame *pending_autoraise_frame; @@ -519,18 +528,24 @@ int x_display_pixel_height (struct w32_display_info *dpyinfo) { - HDC dc = GetDC (NULL); - int pixels = GetDeviceCaps (dc, VERTRES); - ReleaseDC (NULL, dc); + int pixels = GetSystemMetrics (SM_CYVIRTUALSCREEN); + + if (pixels == 0) + /* Fallback for Windows 95 or NT 4.0. */ + pixels = GetSystemMetrics (SM_CYSCREEN); + return pixels; } int x_display_pixel_width (struct w32_display_info *dpyinfo) { - HDC dc = GetDC (NULL); - int pixels = GetDeviceCaps (dc, HORZRES); - ReleaseDC (NULL, dc); + int pixels = GetSystemMetrics (SM_CXVIRTUALSCREEN); + + if (pixels == 0) + /* Fallback for Windows 95 or NT 4.0. */ + pixels = GetSystemMetrics (SM_CXSCREEN); + return pixels; } ------------------------------------------------------------ revno: 113282 committer: Michael Albinus branch nick: trunk timestamp: Thu 2013-07-04 11:43:17 +0200 message: * automated/file-notify-tests.el: New package. diff: === modified file 'test/ChangeLog' --- test/ChangeLog 2013-06-29 03:31:15 +0000 +++ test/ChangeLog 2013-07-04 09:43:17 +0000 @@ -1,3 +1,7 @@ +2013-07-04 Michael Albinus + + * automated/file-notify-tests.el: New package. + 2013-06-28 Kenichi Handa * automated/decoder-tests.el (decoder-tests-gen-file): New arg FILE. === added file 'test/automated/file-notify-tests.el' --- test/automated/file-notify-tests.el 1970-01-01 00:00:00 +0000 +++ test/automated/file-notify-tests.el 2013-07-04 09:43:17 +0000 @@ -0,0 +1,232 @@ +;;; file-notify-tests.el --- Tests of file notifications + +;; Copyright (C) 2013 Free Software Foundation, Inc. + +;; Author: Michael Albinus + +;; 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/'. + +;;; Commentary: + +;; Some of the tests are intended to run over remote files. Set +;; `file-notify-test-remote-temporary-file-directory' to a suitable +;; value. The remote host must also provide the `inotifywait' program. + +;;; Code: + +(require 'ert) +(require 'filenotify) + +(ert-deftest file-notify-test0 () + "Test availability of \\[file-notify]." + (should (memq file-notify-support '(gfilenotify inotify w32notify)))) + +(ert-deftest file-notify-test1 () + "Add watch via \\[file-notify-add-watch]." + (let (desc) + ;; Check, that different valid parameters are accepted. + (should (setq desc (file-notify-add-watch "/" '(change) 'ignore))) + (file-notify-rm-watch desc) + (should (setq desc (file-notify-add-watch "/" '(attribute-change) 'ignore))) + (file-notify-rm-watch desc) + (should (setq desc (file-notify-add-watch + "/" '(change attribute-change) 'ignore))) + (file-notify-rm-watch desc) + + ;; Check error handling. + (should + (equal (car (should-error (file-notify-add-watch 1 2 3 4))) + 'wrong-number-of-arguments)) + (should + (equal (should-error (file-notify-add-watch 1 2 3)) + '(wrong-type-argument 1))) + (should + (equal (should-error (file-notify-add-watch "/" 2 3)) + '(wrong-type-argument 2))) + (should + (equal (should-error (file-notify-add-watch "/" '(change) 3)) + '(wrong-type-argument 3))))) + +(defvar file-notify-test-tmpfile nil) +(defvar file-notify-test-tmpfile1 nil) +(defvar file-notify-test-results nil) +(defconst file-notify-test-remote-temporary-file-directory "/ssh::/tmp" + "Temporary directory for Tramp tests.") + +(defvar tramp-verbose) +(setq tramp-verbose 0) +(defvar file-notify--event) + +(defun file-notify-test-run-remote-test () + "Check, whether the remote tests can be run." + (ignore-errors + (and + (file-directory-p file-notify-test-remote-temporary-file-directory) + (file-writable-p file-notify-test-remote-temporary-file-directory)))) + +(defun file-notify-event-test () + "Ert test function to be called by `file-notify-test-event-handler'. +We cannot pass arguments, so we assume that `file-notify--event' +is bound somewhere." + (message "Event %S" file-notify--event) + ;; Check the file name. + (should + (string-equal (file-notify--event-file-name file-notify--event) + file-notify-test-tmpfile)) + ;; Check the second file name if exists. + (when (eq (nth 1 file-notify--event) 'renamed) + (should + (string-equal + (file-notify--event-file1-name file-notify--event) + file-notify-test-tmpfile1)))) + +(defun file-notify-test-event-handler (file-notify--event) + "Run a test over FILE-NOTIFY--EVENT. +Save the result in `file-notify-test-results', for later analysis." + (let ((result (ert-run-test (make-ert-test :body 'file-notify-event-test)))) + (setq file-notify-test-results + (append file-notify-test-results `(,result))))) + +(defun file-notify-test-make-temp-name () + "Create a temporary file name for test." + (expand-file-name + (make-temp-name "file-notify-test") temporary-file-directory)) + +(ert-deftest file-notify-test2 () + "Check file creation/removal notifications." + (let (desc) + (unwind-protect + (progn + (setq file-notify-test-results nil + file-notify-test-tmpfile (file-notify-test-make-temp-name) + file-notify-test-tmpfile1 (file-notify-test-make-temp-name) + desc + (file-notify-add-watch + file-notify-test-tmpfile + '(change) 'file-notify-test-event-handler)) + + ;; Check creation and removal. + (write-region "any text" nil file-notify-test-tmpfile) + (delete-file file-notify-test-tmpfile) + + ;; Check copy and rename. + (write-region "any text" nil file-notify-test-tmpfile) + (copy-file file-notify-test-tmpfile file-notify-test-tmpfile1) + (delete-file file-notify-test-tmpfile) + (delete-file file-notify-test-tmpfile1) + + (write-region "any text" nil file-notify-test-tmpfile) + (rename-file file-notify-test-tmpfile file-notify-test-tmpfile1) + (delete-file file-notify-test-tmpfile1)) + + ;; Wait for events, and exit. + (sit-for 5 'nodisplay) + (file-notify-rm-watch desc) + (ignore-errors (delete-file file-notify-test-tmpfile)) + (ignore-errors (delete-file file-notify-test-tmpfile1)))) + + (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)))))) + +;; TODO: When the remote test fails, suppress FAILED indication for TEST. +(defmacro file-notify-test-remote (test) + "Run ert TEST for remote files." + `(let* ((temporary-file-directory + file-notify-test-remote-temporary-file-directory) + (ert-test (ert-get-test ,test)) + (most-recent-result (ert-test-most-recent-result ert-test)) + result) + (unwind-protect + (progn + (setq result + (condition-case err + (ert-run-test (ert-get-test ,test)) + ((error quit) + (ert-fail err)))) + (when (ert-test-failed-p result) + (ert-fail + (cadr (ert-test-result-with-condition-condition result))))) + ;; Reset status of TEST. + (setf (ert-test-most-recent-result ert-test) most-recent-result)))) + +(when (file-notify-test-run-remote-test) + (ert-deftest file-notify-test3 () + "Check file creation/removal notification for remote files." + (file-notify-test-remote 'file-notify-test2)) +) ;; (file-notify-test-run-remote-test) + +;; autorevert runs only in interactive mode. +(defvar auto-revert-remote-files) +(setq auto-revert-remote-files t) +(require 'autorevert) +(when (null noninteractive) + + (ert-deftest file-notify-test4 () + "Check autorevert via file notification. +This test is skipped in batch mode." + ;; `auto-revert-buffers' runs every 5". And we must wait, until + ;; the file has been reverted. + (let ((wait 10) + buf) + (unwind-protect + (progn + (setq file-notify-test-tmpfile (file-notify-test-make-temp-name)) + + (write-region "any text" nil file-notify-test-tmpfile) + (setq buf (find-file-noselect file-notify-test-tmpfile)) + (with-current-buffer buf + (should (string-equal (buffer-string) "any text")) + (auto-revert-mode 1) + ;; `auto-revert-buffers' runs every 5". + (sit-for wait) + + ;; Check, that file notification has been used. + (should auto-revert-mode) + (should auto-revert-use-notify) + (should auto-revert-notify-watch-descriptor) + + ;; Modify file. + (shell-command + (format "echo -n 'another text' >%s" + (or (file-remote-p file-notify-test-tmpfile 'localname) + file-notify-test-tmpfile))) + (sit-for wait) + + ;; Check, that the buffer has been reverted. + (should (string-equal (buffer-string) "another text")))) + + ;; Exit. + (ignore-errors (kill-buffer buf)) + (ignore-errors (delete-file file-notify-test-tmpfile))))) + + (when (file-notify-test-run-remote-test) + (ert-deftest file-notify-test5 () + "Check autorevert via file notification for remote files. +This test is skipped in batch mode." + (file-notify-test-remote 'file-notify-test4)) + ) ;; (file-notify-test-run-remote-test) + ) ;; (null noninteractive) + +(defun file-notify-test-all (&optional interactive) + "Run all tests for \\[file-notify]." + (interactive "p") + (when file-notify-support + (if interactive + (ert-run-tests-interactively "^file-notify-") + (ert-run-tests-batch "^file-notify-")))) + +(provide 'file-notify-tests) +;;; file-notify-tests.el ends here ------------------------------------------------------------ revno: 113281 committer: Michael Albinus branch nick: trunk timestamp: Thu 2013-07-04 11:40:56 +0200 message: Add file-notify.el and related changes in Tramp. diff: === modified file 'etc/NEWS' --- etc/NEWS 2013-07-03 23:11:58 +0000 +++ etc/NEWS 2013-07-04 09:40:56 +0000 @@ -411,6 +411,10 @@ *** Handlers for `file-acl' and `set-file-acl' for remote machines which support POSIX ACLs. ++++ +*** Handlers for `file-notify-add-watch' and `file-notify-rm-watch' +for remote machines which support filesystem notifications. + ** VHDL mode *** New options: `vhdl-actual-generic-name', `vhdl-beautify-options'. @@ -424,9 +428,9 @@ ** Eshell -*** Added Eshell-TRAMP module +*** Added Eshell-Tramp module External su and sudo commands are now the default; the internal, -TRAMP-using variants can still be used by enabling the eshell-tramp +Tramp-using variants can still be used by enabling the eshell-tramp module. ** New term.el option `term-suppress-hard-newline'. @@ -466,6 +470,10 @@ - advice-add/advice-remove to add/remove a piece of advice on a named function, much like `defadvice' does. +** The package file-notify.el provides an interface for file system +notifications. It requires, that Emacs is compiled with one of the +low-level libraries gfilenotify.c, inotify.c or w32notify.c. + * Incompatible Lisp Changes in Emacs 24.4 ------------------------------------------------------------ revno: 113280 committer: Michael Albinus branch nick: trunk timestamp: Thu 2013-07-04 11:39:36 +0200 message: * filenotify.el: New package. * autorevert.el (top): Require filenotify.el. (auto-revert-notify-enabled): Remove. Use `file-notify-support' instead. (auto-revert-notify-rm-watch, auto-revert-notify-add-watch) (auto-revert-notify-handler): Use `file-notify-*' functions. * subr.el (file-notify-handle-event): Move function to filenotify.el. * net/tramp.el (tramp-file-name-for-operation): Handle `file-notify-add-watch' and `file-notify-rm-watch'. * net/tramp-sh.el (tramp-sh-file-name-handler-alist): Add handler for `file-notify-add-watch' and `file-notify-rm-watch'. (tramp-process-sentinel): Improve trace. (tramp-sh-handle-file-notify-add-watch) (tramp-sh-file-notify-process-filter) (tramp-sh-handle-file-notify-rm-watch) (tramp-get-remote-inotifywait): New defuns. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2013-07-03 23:11:58 +0000 +++ lisp/ChangeLog 2013-07-04 09:39:36 +0000 @@ -1,3 +1,26 @@ +2013-07-04 Michael Albinus + + * filenotify.el: New package. + + * autorevert.el (top): Require filenotify.el. + (auto-revert-notify-enabled): Remove. Use `file-notify-support' + instead. + (auto-revert-notify-rm-watch, auto-revert-notify-add-watch) + (auto-revert-notify-handler): Use `file-notify-*' functions. + + * subr.el (file-notify-handle-event): Move function to filenotify.el. + + * net/tramp.el (tramp-file-name-for-operation): Handle + `file-notify-add-watch' and `file-notify-rm-watch'. + + * net/tramp-sh.el (tramp-sh-file-name-handler-alist): Add handler + for `file-notify-add-watch' and `file-notify-rm-watch'. + (tramp-process-sentinel): Improve trace. + (tramp-sh-handle-file-notify-add-watch) + (tramp-sh-file-notify-process-filter) + (tramp-sh-handle-file-notify-rm-watch) + (tramp-get-remote-inotifywait): New defuns. + 2013-07-03 Juri Linkov * buff-menu.el (Buffer-menu-multi-occur): Add args and move the @@ -299,12 +322,12 @@ 2013-06-25 Rüdiger Sonderfeld - * lisp/textmodes/bibtex.el (bibtex-generate-url-list): Add support + * textmodes/bibtex.el (bibtex-generate-url-list): Add support for DOI URLs. 2013-06-25 Rüdiger Sonderfeld - * lisp/textmodes/bibtex.el (bibtex-mode, bibtex-set-dialect): + * textmodes/bibtex.el (bibtex-mode, bibtex-set-dialect): Update imenu-support when dialect changes. 2013-06-25 Leo Liu === modified file 'lisp/autorevert.el' --- lisp/autorevert.el 2013-06-05 19:57:10 +0000 +++ lisp/autorevert.el 2013-07-04 09:39:36 +0000 @@ -103,6 +103,7 @@ (eval-when-compile (require 'cl-lib)) (require 'timer) +(require 'filenotify) ;; Custom Group: ;; @@ -270,21 +271,17 @@ :type 'boolean :version "24.4") -(defconst auto-revert-notify-enabled - (or (featurep 'gfilenotify) (featurep 'inotify) (featurep 'w32notify)) - "Non-nil when Emacs has been compiled with file notification support.") - -(defcustom auto-revert-use-notify auto-revert-notify-enabled +(defcustom auto-revert-use-notify (and file-notify-support t) "If non-nil Auto Revert Mode uses file notification functions. This requires Emacs being compiled with file notification -support (see `auto-revert-notify-enabled'). You should set this -variable through Custom." +support (see `file-notify-support'). You should set this variable +through Custom." :group 'auto-revert :type 'boolean :set (lambda (variable value) - (set-default variable (and auto-revert-notify-enabled value)) + (set-default variable (and file-notify-support value)) (unless (symbol-value variable) - (when auto-revert-notify-enabled + (when file-notify-support (dolist (buf (buffer-list)) (with-current-buffer buf (when (symbol-value 'auto-revert-notify-watch-descriptor) @@ -502,12 +499,7 @@ (puthash key value auto-revert-notify-watch-descriptor-hash-list) (remhash key auto-revert-notify-watch-descriptor-hash-list) (ignore-errors - (funcall - (cond - ((fboundp 'gfile-rm-watch) 'gfile-rm-watch) - ((fboundp 'inotify-rm-watch) 'inotify-rm-watch) - ((fboundp 'w32notify-rm-watch) 'w32notify-rm-watch)) - auto-revert-notify-watch-descriptor))))) + (file-notify-rm-watch auto-revert-notify-watch-descriptor))))) auto-revert-notify-watch-descriptor-hash-list) (remove-hook 'kill-buffer-hook 'auto-revert-notify-rm-watch)) (setq auto-revert-notify-watch-descriptor nil @@ -522,100 +514,58 @@ (when (and buffer-file-name auto-revert-use-notify (not auto-revert-notify-watch-descriptor)) - (let ((func - (cond - ((fboundp 'gfile-add-watch) 'gfile-add-watch) - ((fboundp 'inotify-add-watch) 'inotify-add-watch) - ((fboundp 'w32notify-add-watch) 'w32notify-add-watch))) - (aspect - (cond - ((fboundp 'gfile-add-watch) '(watch-mounts)) - ;; `attrib' is needed for file modification time. - ((fboundp 'inotify-add-watch) '(attrib create modify moved-to)) - ((fboundp 'w32notify-add-watch) '(size last-write-time)))) - (file (if (or (fboundp 'gfile-add-watch) (fboundp 'inotify-add-watch)) - (directory-file-name (expand-file-name default-directory)) - (buffer-file-name)))) - (setq auto-revert-notify-watch-descriptor - (ignore-errors - (funcall func file aspect 'auto-revert-notify-handler))) - (if auto-revert-notify-watch-descriptor - (progn - (puthash - auto-revert-notify-watch-descriptor - (cons (current-buffer) - (gethash auto-revert-notify-watch-descriptor - auto-revert-notify-watch-descriptor-hash-list)) - auto-revert-notify-watch-descriptor-hash-list) - (add-hook (make-local-variable 'kill-buffer-hook) - 'auto-revert-notify-rm-watch)) - ;; Fallback to file checks. - (set (make-local-variable 'auto-revert-use-notify) nil))))) - -(defun auto-revert-notify-event-p (event) - "Check that event is a file notification event." - (and (listp event) - (cond ((featurep 'gfilenotify) - (and (>= (length event) 3) (stringp (nth 2 event)))) - ((featurep 'inotify) - (= (length event) 4)) - ((featurep 'w32notify) - (and (= (length event) 3) (stringp (nth 2 event))))))) - -(defun auto-revert-notify-event-descriptor (event) - "Return watch descriptor of file notification event, or nil." - (and (auto-revert-notify-event-p event) (car event))) - -(defun auto-revert-notify-event-action (event) - "Return action of file notification event, or nil." - (and (auto-revert-notify-event-p event) (nth 1 event))) - -(defun auto-revert-notify-event-file-name (event) - "Return file name of file notification event, or nil." - (and (auto-revert-notify-event-p event) - (cond ((featurep 'gfilenotify) (nth 2 event)) - ((featurep 'inotify) (nth 3 event)) - ((featurep 'w32notify) (nth 2 event))))) + (setq auto-revert-notify-watch-descriptor + (ignore-errors + (file-notify-add-watch + (expand-file-name buffer-file-name default-directory) + '(change attribute-change) 'auto-revert-notify-handler))) + (if auto-revert-notify-watch-descriptor + (progn + (puthash + auto-revert-notify-watch-descriptor + (cons (current-buffer) + (gethash auto-revert-notify-watch-descriptor + auto-revert-notify-watch-descriptor-hash-list)) + auto-revert-notify-watch-descriptor-hash-list) + (add-hook (make-local-variable 'kill-buffer-hook) + 'auto-revert-notify-rm-watch)) + ;; Fallback to file checks. + (set (make-local-variable 'auto-revert-use-notify) nil)))) (defun auto-revert-notify-handler (event) "Handle an EVENT returned from file notification." - (when (auto-revert-notify-event-p event) - (let* ((descriptor (auto-revert-notify-event-descriptor event)) - (action (auto-revert-notify-event-action event)) - (file (auto-revert-notify-event-file-name event)) + (ignore-errors + (let* ((descriptor (car event)) + (action (nth 1 event)) + (file (nth 2 event)) + (file1 (nth 3 event)) ;; Target of `renamed'. (buffers (gethash descriptor auto-revert-notify-watch-descriptor-hash-list))) - (ignore-errors - ;; Check, that event is meant for us. - ;; TODO: Filter events which stop watching, like `move' or `removed'. - (cl-assert descriptor) - (cond - ((featurep 'gfilenotify) - (cl-assert (memq action '(attribute-changed changed created deleted - ;; FIXME: I keep getting this action, so I - ;; added it here, but I have no idea what - ;; I'm doing. --Stef - changes-done-hint)) - t)) - ((featurep 'inotify) - (cl-assert (or (memq 'attrib action) - (memq 'create action) - (memq 'modify action) - (memq 'moved-to action)))) - ((featurep 'w32notify) (cl-assert (eq 'modified action)))) - ;; Since we watch a directory, a file name must be returned. - (cl-assert (stringp file)) - (dolist (buffer buffers) - (when (buffer-live-p buffer) - (with-current-buffer buffer - (when (and (stringp buffer-file-name) - (string-equal - (file-name-nondirectory file) - (file-name-nondirectory buffer-file-name))) - ;; Mark buffer modified. - (setq auto-revert-notify-modified-p t) - ;; No need to check other buffers. - (cl-return))))))))) + ;; Check, that event is meant for us. + (cl-assert descriptor) + ;; We do not handle `deleted', because nothing has to be refreshed. + (cl-assert (memq action '(attribute-changed changed created renamed)) t) + ;; 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. + (dolist (buffer buffers) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (when (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))))) + ;; Mark buffer modified. + (setq auto-revert-notify-modified-p t) + ;; No need to check other buffers. + (cl-return)))))))) (defun auto-revert-active-p () "Check if auto-revert is active (in current buffer or globally)." === added file 'lisp/filenotify.el' --- lisp/filenotify.el 1970-01-01 00:00:00 +0000 +++ lisp/filenotify.el 2013-07-04 09:39:36 +0000 @@ -0,0 +1,324 @@ +;;; filenotify.el --- watch files for changes on disk + +;; Copyright (C) 2013 Free Software Foundation, Inc. + +;; Author: Michael Albinus + +;; 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 . + +;;; Commentary + +;; This package is an abstraction layer from the different low-level +;; file notification packages `gfilenotify', `inotify' and +;; `w32notify'. + +;;; Code: + +;;;###autoload +(defconst file-notify-support + (cond + ((featurep 'gfilenotify) 'gfilenotify) + ((featurep 'inotify) 'inotify) + ((featurep 'w32notify) 'w32notify)) + "Non-nil when Emacs has been compiled with file notification support. +The value is the name of the low-level file notification package +to be used for local file systems. Remote file notifications +could use another implementation.") + +(defvar file-notify-descriptors (make-hash-table :test 'equal) + "Hash table for registered file notification descriptors. +A key in this hash table is the descriptor as returned from +`gfilenotify', `inotify', `w32notify' or a file name handler. +The value in the hash table is the cons cell (DIR FILE CALLBACK).") + +;; This function is used by `gfilenotify', `inotify' and `w32notify' events. +;;;###autoload +(defun file-notify-handle-event (event) + "Handle file system monitoring event. +If EVENT is a filewatch event, call its callback. +Otherwise, signal a `file-notify-error'." + (interactive "e") + (if (and (eq (car event) 'file-notify) + (>= (length event) 3)) + (funcall (nth 2 event) (nth 1 event)) + (signal 'file-notify-error + (cons "Not a valid file-notify event" event)))) + +(defvar file-notify--pending-events nil + "List of pending file notification events for a future `renamed' action. +The entries are a list (DESCRIPTOR ACTION FILE COOKIE). ACTION +is either `moved-from' or `renamed-from'.") + +(defun file-notify--event-file-name (event) + "Return file name of file notification event, or nil." + (expand-file-name + (or (and (stringp (nth 2 event)) (nth 2 event)) "") + (car (gethash (car event) file-notify-descriptors)))) + +;; Only `gfilenotify' could return two file names. +(defun file-notify--event-file1-name (event) + "Return second file name of file notification event, or nil. +This is available in case a file has been moved." + (and (stringp (nth 3 event)) + (expand-file-name + (nth 3 event) (car (gethash (car event) file-notify-descriptors))))) + +;; Cookies are offered by `inotify' only. +(defun file-notify--event-cookie (event) + "Return cookie of file notification event, or nil. +This is available in case a file has been moved." + (nth 3 event)) + +;; The callback function used to map between specific flags of the +;; respective file notifications, and the ones we return. +(defun file-notify-callback (event) + "Handle an EVENT returned from file notification. +EVENT is the same one as in `file-notify-handle-event' except the +car of that event, which is the symbol `file-notify'." + (let* ((desc (car event)) + (registered (gethash desc file-notify-descriptors)) + (pending-event (assoc desc file-notify--pending-events)) + (actions (nth 1 event)) + (file (file-notify--event-file-name event)) + file1 cookie callback) + + ;; Make actions a list. + (unless (consp actions) (setq actions (cons actions nil))) + + ;; Check, that event is meant for us. + (unless (setq callback (nth 2 registered)) + (setq actions nil)) + + ;; Loop over actions. In fact, more than one action happens only + ;; for `inotify'. + (dolist (action actions) + + ;; Send pending event, if it doesn't match. + (when (and pending-event + ;; The cookie doesn't match. + (not (eq (file-notify--event-cookie pending-event) + (file-notify--event-cookie event))) + (or + ;; inotify. + (and (eq (nth 1 pending-event) 'moved-from) + (not (eq action 'moved-to))) + ;; w32notify. + (and (eq (nth 1 pending-event) 'renamed-from) + (not (eq action 'renamed-to))))) + (funcall callback + (list desc 'deleted + (file-notify--event-file-name pending-event))) + (setq file-notify--pending-events + (delete pending-event file-notify--pending-events))) + + ;; Map action. We ignore all events which cannot be mapped. + (setq action + (cond + ;; gfilenotify. + ((memq action '(attribute-changed changed created deleted)) action) + ((eq action 'moved) + (setq file1 (file-notify--event-file1-name event)) + 'renamed) + + ;; inotify. + ((eq action 'attrib) 'attribute-changed) + ((eq action 'create) 'created) + ((eq action 'modify) 'changed) + ((memq action '(delete 'delete-self move-self)) 'deleted) + ;; Make the event pending. + ((eq action 'moved-from) + (add-to-list 'file-notify--pending-events + (list desc action file + (file-notify--event-cookie event))) + nil) + ;; Look for pending event. + ((eq action 'moved-to) + (if (null pending-event) + 'created + (setq file1 file + file (file-notify--event-file-name pending-event) + file-notify--pending-events + (delete pending-event file-notify--pending-events)) + 'renamed)) + + ;; w32notify. + ((eq action 'added) 'created) + ((eq action 'modified) 'changed) + ((eq action 'removed) 'deleted) + ;; Make the event pending. + ((eq 'renamed-from action) + (add-to-list 'file-notify--pending-events + (list desc action file + (file-notify--event-cookie event))) + nil) + ;; Look for pending event. + ((eq 'renamed-to action) + (if (null pending-event) + 'created + (setq file1 file + file (file-notify--event-file-name pending-event) + file-notify--pending-events + (delete pending-event file-notify--pending-events)) + 'renamed)))) + + ;; Apply callback. + (when (and action + (or + ;; If there is no relative file name for that watch, + ;; we watch the whole directory. + (null (nth 1 registered)) + ;; File matches. + (string-equal + (nth 1 registered) (file-name-nondirectory file)) + ;; File1 matches. + (and (stringp file1) + (string-equal + (nth 1 registered) (file-name-nondirectory file1))))) + (if file1 + (funcall callback (list desc action file file1)) + (funcall callback (list desc action file))))))) + +(defun file-notify-add-watch (file flags callback) + "Add a watch for filesystem events pertaining to FILE. +This arranges for filesystem events pertaining to FILE to be reported +to Emacs. Use `file-notify-rm-watch' to cancel the watch. + +The returned value is a descriptor for the added watch. If the +file cannot be watched for some reason, this function signals a +`file-notify-error' error. + +FLAGS is a list of conditions to set what will be watched for. It can +include the following symbols: + + `change' -- watch for file changes + `attribute-change' -- watch for file attributes changes, like + permissions or modification time + +If FILE is a directory, 'change' watches for file creation or +deletion in that directory. + +When any event happens, Emacs will call the CALLBACK function passing +it a single argument EVENT, which is of the form + + (DESCRIPTOR ACTION FILE [FILE1]) + +DESCRIPTOR is the same object as the one returned by this function. +ACTION is the description of the event. It could be any one of the +following: + + `created' -- FILE was created + `deleted' -- FILE was deleted + `changed' -- FILE has changed + `renamed' -- FILE has been renamed to FILE1 + `attribute-changed' -- a FILE attribute was changed + +FILE is the name of the file whose event is being reported." + ;; Check arguments. + (unless (stringp file) + (signal 'wrong-type-argument (list 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))) + (unless (functionp callback) + (signal 'wrong-type-argument (list callback))) + + (let* ((handler (find-file-name-handler file 'file-notify-add-watch)) + (dir (directory-file-name + (if (or (and (not handler) (eq file-notify-support 'w32notify)) + (file-directory-p file)) + file + (file-name-directory file)))) + desc func l-flags) + + ;; Check, whether this has been registered already. +; (maphash +; (lambda (key value) +; (when (equal (cons file callback) value) (setq desc key))) +; file-notify-descriptors) + + (unless desc + (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. + (unless file-notify-support + (signal 'file-notify-error + '("No file notification package available"))) + + ;; Determine low-level function to be called. + (setq func (cond + ((eq file-notify-support 'gfilenotify) 'gfile-add-watch) + ((eq file-notify-support 'inotify) 'inotify-add-watch) + ((eq file-notify-support 'w32notify) 'w32notify-add-watch))) + + ;; Determine respective flags. + (if (eq file-notify-support 'gfilenotify) + (setq l-flags '(watch-mounts send-moved)) + (when (memq 'change flags) + (setq + l-flags + (cond + ((eq file-notify-support 'inotify) '(create modify move delete)) + ((eq file-notify-support 'w32notify) + '(file-name directory-name size last-write-time))))) + (when (memq 'attribute-change flags) + (add-to-list + 'l-flags + (cond + ((eq file-notify-support 'inotify) 'attrib) + ((eq file-notify-support 'w32notify) 'attributes))))) + + ;; Call low-level function. + (setq desc (funcall func dir l-flags 'file-notify-callback)))) + + ;; Return descriptor. + (puthash desc + (list (directory-file-name + (if (file-directory-p dir) dir (file-name-directory dir))) + (unless (file-directory-p file) + (file-name-nondirectory file)) + callback) + file-notify-descriptors) + desc)) + +(defun file-notify-rm-watch (descriptor) + "Remove an existing watch specified by its DESCRIPTOR. +DESCRIPTOR should be an object returned by `file-notify-add-watch'." + (let ((file (car (gethash descriptor file-notify-descriptors))) + handler) + + (when (stringp file) + (setq handler (find-file-name-handler file 'file-notify-rm-watch)) + (if handler + (funcall handler 'file-notify-rm-watch descriptor) + (funcall + (cond + ((eq file-notify-support 'gfilenotify) 'gfile-rm-watch) + ((eq file-notify-support 'inotify) 'inotify-rm-watch) + ((eq file-notify-support 'w32notify) 'w32notify-rm-watch)) + descriptor))) + + (remhash descriptor file-notify-descriptors))) + +;; The end: +(provide 'filenotify) + +;;; filenotify.el ends here === modified file 'lisp/net/tramp-sh.el' --- lisp/net/tramp-sh.el 2013-06-19 13:14:24 +0000 +++ lisp/net/tramp-sh.el 2013-07-04 09:39:36 +0000 @@ -862,7 +862,9 @@ (set-file-selinux-context . tramp-sh-handle-set-file-selinux-context) (file-acl . tramp-sh-handle-file-acl) (set-file-acl . tramp-sh-handle-set-file-acl) - (vc-registered . tramp-sh-handle-vc-registered)) + (vc-registered . tramp-sh-handle-vc-registered) + (file-notify-add-watch . tramp-sh-handle-file-notify-add-watch) + (file-notify-rm-watch . tramp-sh-handle-file-notify-rm-watch)) "Alist of handler functions. Operations not mentioned here will be handled by the normal Emacs functions.") @@ -2669,7 +2671,7 @@ (unless (memq (process-status proc) '(run open)) (let ((vec (tramp-get-connection-property proc "vector" nil))) (when vec - (tramp-message vec 5 "Sentinel called: `%s' `%s'" proc event) + (tramp-message vec 5 "Sentinel called: `%S' `%s'" proc event) (tramp-flush-connection-property proc) (tramp-flush-directory-property vec ""))))) @@ -3376,6 +3378,63 @@ ;; Default file name handlers, we don't care. (t (tramp-run-real-handler operation args))))))) +;; We use inotify for implementation. It is more likely to exist than glib. +(defun tramp-sh-handle-file-notify-add-watch (file-name flags callback) + "Like `file-notify-add-watch' for Tramp files." + (setq file-name (expand-file-name file-name)) + (with-parsed-tramp-file-name file-name nil + (let* ((default-directory (file-name-directory file-name)) + (command (tramp-get-remote-inotifywait v)) + (events + (cond + ((and (memq 'change flags) (memq 'attribute-change flags)) + "create,modify,move,delete,attrib") + ((memq 'change flags) "create,modify,move,delete") + ((memq 'attribute-change flags) "attrib"))) + (p (and command + (start-file-process + "inotifywait" (generate-new-buffer " *inotifywait*") + command "-mq" "-e" events localname)))) + ;; Return the process object as watch-descriptor. + (if (not (processp p)) + (tramp-error + v 'file-notify-error "`inotifywait' not found on remote host") + (tramp-compat-set-process-query-on-exit-flag p nil) + (set-process-filter p 'tramp-sh-file-notify-process-filter) + p)))) + +(defun tramp-sh-file-notify-process-filter (proc string) + "Read output from \"inotifywait\" and add corresponding file-notify events." + (tramp-message proc 6 (format "%S\n%s" proc string)) + (dolist (line (split-string string "[\n\r]+" 'omit-nulls)) + ;; Check, whether there is a problem. + (unless + (string-match + "^[^[:blank:]]+[[:blank:]]+\\([^[:blank:]]+\\)+\\([[:blank:]]+\\([^[:blank:]]+\\)\\)?[[:blank:]]*$" line) + (tramp-error proc 'file-notify-error "%s" line)) + + ;; Usually, we would add an Emacs event now. Unfortunately, + ;; `unread-command-events' does not accept several events at once. + ;; Therefore, we apply the callback directly. + (let* ((object + (list + proc + (mapcar + (lambda (x) + (intern-soft (replace-regexp-in-string "_" "-" (downcase x)))) + (split-string (match-string 1 line) "," 'omit-nulls)) + (match-string 3 line)))) + (tramp-compat-funcall 'file-notify-callback object)))) + +(defvar file-notify-descriptors) +(defun tramp-sh-handle-file-notify-rm-watch (proc) + "Like `file-notify-rm-watch' for Tramp files." + ;; The descriptor must be a process object. + (unless (and (processp proc) (gethash proc file-notify-descriptors)) + (tramp-error proc 'file-notify-error "Not a valid descriptor %S" proc)) + (tramp-message proc 6 (format "Kill %S" proc)) + (kill-process proc)) + ;;; Internal Functions: (defun tramp-maybe-send-script (vec script name) @@ -4864,6 +4923,11 @@ (tramp-message vec 5 "Finding a suitable `trash' command") (tramp-find-executable vec "trash" (tramp-get-remote-path vec)))) +(defun tramp-get-remote-inotifywait (vec) + (with-tramp-connection-property vec "inotifywait" + (tramp-message vec 5 "Finding a suitable `inotifywait' command") + (tramp-find-executable vec "inotifywait" (tramp-get-remote-path vec) t t))) + (defun tramp-get-remote-id (vec) (with-tramp-connection-property vec "id" (tramp-message vec 5 "Finding POSIX `id' command") === modified file 'lisp/net/tramp.el' --- lisp/net/tramp.el 2013-04-22 10:26:09 +0000 +++ lisp/net/tramp.el 2013-07-04 09:39:36 +0000 @@ -1964,7 +1964,7 @@ ;; Emacs 22+ only. 'set-file-times ;; Emacs 24+ only. - 'file-acl 'file-selinux-context + 'file-acl 'file-notify-add-watch 'file-selinux-context 'set-file-acl 'set-file-selinux-context ;; XEmacs only. 'abbreviate-file-name 'create-file-buffer @@ -2018,6 +2018,10 @@ ;; XEmacs only. 'dired-print-file 'dired-shell-call-process)) default-directory) + ;; PROC. + ((eq operation 'file-notify-rm-watch) + (with-current-buffer (process-buffer (nth 0 args)) + default-directory)) ;; Unknown file primitive. (t (error "unknown file I/O primitive: %s" operation)))) === modified file 'lisp/subr.el' --- lisp/subr.el 2013-07-03 03:20:04 +0000 +++ lisp/subr.el 2013-07-04 09:39:36 +0000 @@ -4496,20 +4496,6 @@ nil ,@(cdr (cdr spec))))) -;;;; Support for watching filesystem events. - -(defun file-notify-handle-event (event) - "Handle file system monitoring event. -If EVENT is a filewatch event, call its callback. -Otherwise, signal a `filewatch-error'." - (interactive "e") - (if (and (eq (car event) 'file-notify) - (>= (length event) 3)) - (funcall (nth 2 event) (nth 1 event)) - (signal 'filewatch-error - (cons "Not a valid file-notify event" event)))) - - ;;;; Comparing version strings. (defconst version-separator "." ------------------------------------------------------------ revno: 113279 committer: Michael Albinus branch nick: trunk timestamp: Thu 2013-07-04 11:29:28 +0200 message: * fileio.c (Qfile_notify_error): New error symbol. * gfilenotify.c (Fgfile_add_watch, Fgfile_rm_watch): * inotify.c (inotify_callback, symbol_to_inotifymask) (Finotify_add_watch, Finotify_rm_watch): Use it. (inotifyevent_to_event): Exchange order of cookie and file name. (Finotify_add_watch): Adapt docstring. * lisp.h (Qfile_notify_error): Declare. diff: === modified file 'src/ChangeLog' --- src/ChangeLog 2013-07-04 06:20:55 +0000 +++ src/ChangeLog 2013-07-04 09:29:28 +0000 @@ -1,3 +1,15 @@ +2013-07-04 Michael Albinus + + * fileio.c (Qfile_notify_error): New error symbol. + + * gfilenotify.c (Fgfile_add_watch, Fgfile_rm_watch): + * inotify.c (inotify_callback, symbol_to_inotifymask) + (Finotify_add_watch, Finotify_rm_watch): Use it. + (inotifyevent_to_event): Exchange order of cookie and file name. + (Finotify_add_watch): Adapt docstring. + + * lisp.h (Qfile_notify_error): Declare. + 2013-07-04 Paul Eggert Try again to fix FreeBSD bug re multithreaded memory alloc (Bug#14569). === modified file 'src/fileio.c' --- src/fileio.c 2013-06-18 07:42:37 +0000 +++ src/fileio.c 2013-07-04 09:29:28 +0000 @@ -148,7 +148,7 @@ #ifdef WINDOWSNT #endif -Lisp_Object Qfile_error; +Lisp_Object Qfile_error, Qfile_notify_error; static Lisp_Object Qfile_already_exists, Qfile_date_error; static Lisp_Object Qexcl; Lisp_Object Qfile_name_history; @@ -5887,6 +5887,7 @@ DEFSYM (Qfile_error, "file-error"); DEFSYM (Qfile_already_exists, "file-already-exists"); DEFSYM (Qfile_date_error, "file-date-error"); + DEFSYM (Qfile_notify_error, "file-notify-error"); DEFSYM (Qexcl, "excl"); DEFVAR_LISP ("file-name-coding-system", Vfile_name_coding_system, @@ -5925,6 +5926,11 @@ Fput (Qfile_date_error, Qerror_message, build_pure_c_string ("Cannot set file date")); + Fput (Qfile_notify_error, Qerror_conditions, + Fpurecopy (list3 (Qfile_notify_error, Qfile_error, Qerror))); + Fput (Qfile_notify_error, Qerror_message, + build_pure_c_string ("File notification error")); + DEFVAR_LISP ("file-name-handler-alist", Vfile_name_handler_alist, doc: /* Alist of elements (REGEXP . HANDLER) for file names handled specially. If a file name matches REGEXP, all I/O on that file is done by calling === modified file 'src/gfilenotify.c' --- src/gfilenotify.c 2013-06-06 07:04:35 +0000 +++ src/gfilenotify.c 2013-07-04 09:29:28 +0000 @@ -132,15 +132,14 @@ to Emacs. Use `gfile-rm-watch' to cancel the watch. Value is a descriptor for the added watch. If the file cannot be -watched for some reason, this function signals a `file-error' error. +watched for some reason, this function signals a `file-notify-error' error. FLAGS is a list of conditions to set what will be watched for. It can include the following symbols: 'watch-mounts' -- watch for mount events 'send-moved' -- pair 'deleted' and 'created' events caused by file - renames (moves) and send a single 'event-moved' - event instead + renames and send a single 'renamed' event instead When any event happens, Emacs will call the CALLBACK function passing it a single argument EVENT, which is of the form @@ -193,7 +192,7 @@ /* Enable watch. */ monitor = g_file_monitor (gfile, gflags, NULL, NULL); if (! monitor) - xsignal2 (Qfile_error, build_string ("Cannot watch file"), file); + xsignal2 (Qfile_notify_error, build_string ("Cannot watch file"), file); /* On all known glib platforms, converting MONITOR directly to a Lisp_Object value results is a Lisp integer, which is safe. This @@ -202,7 +201,8 @@ if (! INTEGERP (watch_descriptor)) { g_object_unref (monitor); - xsignal2 (Qfile_error, build_string ("Unsupported file watcher"), file); + xsignal2 (Qfile_notify_error, build_string ("Unsupported file watcher"), + file); } g_signal_connect (monitor, "changed", @@ -226,14 +226,14 @@ Lisp_Object watch_object = assq_no_quit (watch_descriptor, watch_list); if (! CONSP (watch_object)) - xsignal2 (Qfile_error, build_string ("Not a watch descriptor"), + xsignal2 (Qfile_notify_error, build_string ("Not a watch descriptor"), watch_descriptor); eassert (INTEGERP (watch_descriptor)); int_monitor = XLI (watch_descriptor); monitor = (GFileMonitor *) int_monitor; if (!g_file_monitor_cancel (monitor)) - xsignal2 (Qfile_error, build_string ("Could not rm watch"), + xsignal2 (Qfile_notify_error, build_string ("Could not rm watch"), watch_descriptor); /* Remove watch descriptor from watch list. */ === modified file 'src/inotify.c' --- src/inotify.c 2013-01-02 16:30:50 +0000 +++ src/inotify.c 2013-07-04 09:29:28 +0000 @@ -139,8 +139,8 @@ return list2 (list4 (make_watch_descriptor (ev->wd), mask_to_aspects (ev->mask), - make_number (ev->cookie), - name), + name, + make_number (ev->cookie)), XCDR (watch_object)); } @@ -158,15 +158,17 @@ to_read = 0; if (ioctl (fd, FIONREAD, &to_read) == -1) - report_file_error ("Error while trying to retrieve file system events", - Qnil); + xsignal1 + (Qfile_notify_error, + build_string ("Error while trying to retrieve file system events")); buffer = xmalloc (to_read); n = read (fd, buffer, to_read); if (n < 0) { xfree (buffer); - report_file_error ("Error while trying to read file system events", - Qnil); + xsignal1 + (Qfile_notify_error, + build_string ("Error while trying to read file system events")); } EVENT_INIT (event); @@ -242,7 +244,7 @@ else if (EQ (symb, Qt) || EQ (symb, Qall_events)) return IN_ALL_EVENTS; else - signal_error ("Unknown aspect", symb); + xsignal2 (Qfile_notify_error, build_string ("Unknown aspect"), symb); } static uint32_t @@ -298,7 +300,7 @@ event. It gets passed a single argument EVENT which contains an event structure of the format -(WATCH-DESCRIPTOR ASPECTS COOKIE NAME) +(WATCH-DESCRIPTOR ASPECTS NAME COOKIE) WATCH-DESCRIPTOR is the same object that was returned by this function. It can be tested for equality using `equal'. ASPECTS describes the event. It is a @@ -310,11 +312,11 @@ q-overflow unmount +If a directory is watched then NAME is the name of file that caused the event. + COOKIE is an object that can be compared using `equal' to identify two matching renames (moved-from and moved-to). -If a directory is watched then NAME is the name of file that caused the event. - See inotify(7) and inotify_add_watch(2) for further information. The inotify fd is managed internally and there is no corresponding inotify_init. Use `inotify-rm-watch' to remove a watch. @@ -335,8 +337,9 @@ if (inotifyfd == -1) { inotifyfd = uninitialized; - report_file_error ("File watching feature (inotify) is not available", - Qnil); + xsignal1 + (Qfile_notify_error, + build_string ("File watching feature (inotify) is not available")); } watch_list = Qnil; add_read_fd (inotifyfd, &inotify_callback, NULL); @@ -346,7 +349,8 @@ encoded_file_name = ENCODE_FILE (file_name); watchdesc = inotify_add_watch (inotifyfd, SSDATA (encoded_file_name), mask); if (watchdesc == -1) - report_file_error ("Could not add watch for file", Fcons (file_name, Qnil)); + xsignal2 (Qfile_notify_error, + build_string ("Could not add watch for file"), file_name); watch_descriptor = make_watch_descriptor (watchdesc); @@ -375,8 +379,8 @@ int wd = XINT (watch_descriptor); if (inotify_rm_watch (inotifyfd, wd) == -1) - report_file_error ("Could not rm watch", Fcons (watch_descriptor, - Qnil)); + xsignal2 (Qfile_notify_error, + build_string ("Could not rm watch"), watch_descriptor); /* Remove watch descriptor from watch list. */ watch_object = Fassoc (watch_descriptor, watch_list); === modified file 'src/lisp.h' --- src/lisp.h 2013-07-02 03:41:16 +0000 +++ src/lisp.h 2013-07-04 09:29:28 +0000 @@ -3809,6 +3809,7 @@ /* Defined in fileio.c. */ extern Lisp_Object Qfile_error; +extern Lisp_Object Qfile_notify_error; extern Lisp_Object Qfile_exists_p; extern Lisp_Object Qfile_directory_p; extern Lisp_Object Qinsert_file_contents; ------------------------------------------------------------ revno: 113278 fixes bug: http://debbugs.gnu.org/14569 committer: Paul Eggert branch nick: trunk timestamp: Wed 2013-07-03 23:20:55 -0700 message: Try again to fix FreeBSD bug re multithreaded memory alloc. * emacs.c (main) [HAVE_PTHREAD && !SYSTEM_MALLOC && !DOUG_LEA_MALLOC]: Do not clear _malloc_thread_enabled_p, undoing the previous change, which did not work (see ). (main): Do not invoke malloc_enable_thread if (! CANNOT_DUMP && (!noninteractive || initialized)). This attempts to thread the needle between the Scylla of FreeBSD and the Charybdis of Cygwin. diff: === modified file 'src/ChangeLog' --- src/ChangeLog 2013-07-04 02:08:56 +0000 +++ src/ChangeLog 2013-07-04 06:20:55 +0000 @@ -1,3 +1,13 @@ +2013-07-04 Paul Eggert + + Try again to fix FreeBSD bug re multithreaded memory alloc (Bug#14569). + * emacs.c (main) [HAVE_PTHREAD && !SYSTEM_MALLOC && !DOUG_LEA_MALLOC]: + Do not clear _malloc_thread_enabled_p, undoing the previous change, + which did not work (see ). + (main): Do not invoke malloc_enable_thread if (! CANNOT_DUMP + && (!noninteractive || initialized)). This attempts to thread + the needle between the Scylla of FreeBSD and the Charybdis of Cygwin. + 2013-07-04 Juanma Barranquero * image.c (x_to_xcolors) [HAVE_NTGUI]: Remove unused var `hdc'. === modified file 'src/emacs.c' --- src/emacs.c 2013-07-04 00:53:13 +0000 +++ src/emacs.c 2013-07-04 06:20:55 +0000 @@ -128,7 +128,6 @@ dumping. Used to work around a bug in glibc's malloc. */ static bool malloc_using_checking; #elif defined HAVE_PTHREAD && !defined SYSTEM_MALLOC -extern int _malloc_thread_enabled_p; extern void malloc_enable_thread (void); #endif @@ -682,12 +681,6 @@ stack_base = &dummy; #endif -#if defined HAVE_PTHREAD && !defined SYSTEM_MALLOC && !defined DOUG_LEA_MALLOC - /* Disable mutexes in gmalloc.c. Otherwise, FreeBSD Emacs recursively - loops with pthread_mutex_lock calling calloc and vice versa. */ - _malloc_thread_enabled_p = 0; -#endif - #ifdef G_SLICE_ALWAYS_MALLOC /* This is used by the Cygwin build. */ xputenv ("G_SLICE=always-malloc"); @@ -1084,7 +1077,14 @@ } #if defined HAVE_PTHREAD && !defined SYSTEM_MALLOC && !defined DOUG_LEA_MALLOC - malloc_enable_thread (); +# ifndef CANNOT_DUMP + /* Do not make gmalloc thread-safe when creating bootstrap-emacs, as + that causes an infinite recursive loop with FreeBSD. But do make + it thread-safe when creating emacs, otherwise bootstrap-emacs + fails on Cygwin. See Bug#14569. */ + if (!noninteractive || initialized) +# endif + malloc_enable_thread (); #endif init_signals (dumping);