Add support for x-support-frames

* src/pgtkfns.c (Fx_export_frames):
(syms_of_pgtkfns): port from X11 version
* src/pgtkterm.c (pgtk_cr_accumulate_data):
(pgtk_cr_destroy):
(pgtk_cr_export_frames): port from X11
* src/pgtkterm.h: add defs

3 files changed, 199 insertions, 1 deletions

diff --git a/src/pgtkfns.c b/src/pgtkfns.c
index 53da9b756aa..06fb4e206f4 100644
--- a/src/pgtkfns.c
+++ b/src/pgtkfns.c
@@ -844,6 +844,78 @@ pgtk_set_scroll_bar_background (struct frame *f, Lisp_Object new_value,
     error ("Invalid scroll-bar-background.");
 }
 
+
+/***********************************************************************
+                               Printing
+ ***********************************************************************/
+
+
+DEFUN ("x-export-frames", Fx_export_frames, Sx_export_frames, 0, 2, 0,
+       doc: /* Return image data of FRAMES in TYPE format.
+FRAMES should be nil (the selected frame), a frame, or a list of
+frames (each of which corresponds to one page).  Each frame should be
+visible.  Optional arg TYPE should be either `pdf' (default), `png',
+`postscript', or `svg'.  Supported types are determined by the
+compile-time configuration of cairo.
+
+Note: Text drawn with the `x' font backend is shown with hollow boxes
+unless TYPE is `png'.  */)
+     (Lisp_Object frames, Lisp_Object type)
+{
+  Lisp_Object rest, tmp;
+  cairo_surface_type_t surface_type;
+
+  if (!CONSP (frames))
+    frames = list1 (frames);
+
+  tmp = Qnil;
+  for (rest = frames; CONSP (rest); rest = XCDR (rest))
+    {
+      struct frame *f = decode_window_system_frame (XCAR (rest));
+      Lisp_Object frame;
+
+      XSETFRAME (frame, f);
+      if (!FRAME_VISIBLE_P (f))
+        error ("Frames to be exported must be visible.");
+      tmp = Fcons (frame, tmp);
+    }
+  frames = Fnreverse (tmp);
+
+#ifdef CAIRO_HAS_PDF_SURFACE
+  if (NILP (type) || EQ (type, Qpdf))
+    surface_type = CAIRO_SURFACE_TYPE_PDF;
+  else
+#endif
+#ifdef CAIRO_HAS_PNG_FUNCTIONS
+  if (EQ (type, Qpng))
+    {
+      if (!NILP (XCDR (frames)))
+        error ("PNG export cannot handle multiple frames.");
+      surface_type = CAIRO_SURFACE_TYPE_IMAGE;
+    }
+  else
+#endif
+#ifdef CAIRO_HAS_PS_SURFACE
+  if (EQ (type, Qpostscript))
+    surface_type = CAIRO_SURFACE_TYPE_PS;
+  else
+#endif
+#ifdef CAIRO_HAS_SVG_SURFACE
+  if (EQ (type, Qsvg))
+    {
+      /* For now, we stick to SVG 1.1.  */
+      if (!NILP (XCDR (frames)))
+        error ("SVG export cannot handle multiple frames.");
+      surface_type = CAIRO_SURFACE_TYPE_SVG;
+    }
+  else
+#endif
+    error ("Unsupported export type");
+
+  return pgtk_cr_export_frames (frames, surface_type);
+}
+
+
 /* Note: see frame.c for template, also where generic functions are impl */
 frame_parm_handler pgtk_frame_parm_handlers[] = {
   gui_set_autoraise,            /* generic OK */
@@ -3673,7 +3745,7 @@ be used as the image of the icon representing the frame.  */);
   defsubr (&Sx_show_tip);
   defsubr (&Sx_hide_tip);
 
-  // defsubr (&Spgtk_export_frames);
+  defsubr (&Sx_export_frames);
   defsubr (&Spgtk_page_setup_dialog);
   defsubr (&Spgtk_get_page_setup);
   defsubr (&Spgtk_print_frames_dialog);
diff --git a/src/pgtkterm.c b/src/pgtkterm.c
index 544436e6e44..6d8b1ece877 100644
--- a/src/pgtkterm.c
+++ b/src/pgtkterm.c
@@ -7045,6 +7045,17 @@ pgtk_cr_draw_frame (cairo_t * cr, struct frame *f)
   cairo_paint (cr);
 }
 
+static cairo_status_t
+pgtk_cr_accumulate_data (void *closure, const unsigned char *data,
+                      unsigned int length)
+{
+  Lisp_Object *acc = (Lisp_Object *) closure;
+
+  *acc = Fcons (make_unibyte_string ((char const *) data, length), *acc);
+
+  return CAIRO_STATUS_SUCCESS;
+}
+
 void
 pgtk_cr_destroy_frame_context (struct frame *f)
 {
@@ -7056,6 +7067,110 @@ pgtk_cr_destroy_frame_context (struct frame *f)
     }
 }
 
+static void
+pgtk_cr_destroy (void *cr)
+{
+  block_input ();
+  cairo_destroy (cr);
+  unblock_input ();
+}
+
+
+
+Lisp_Object
+pgtk_cr_export_frames (Lisp_Object frames, cairo_surface_type_t surface_type)
+{
+  struct frame *f;
+  cairo_surface_t *surface;
+  cairo_t *cr;
+  int width, height;
+  void (*surface_set_size_func) (cairo_surface_t *, double, double) = NULL;
+  Lisp_Object acc = Qnil;
+  ptrdiff_t count = SPECPDL_INDEX ();
+
+  specbind (Qredisplay_dont_pause, Qt);
+  redisplay_preserve_echo_area (31);
+
+  f = XFRAME (XCAR (frames));
+  frames = XCDR (frames);
+  width = FRAME_PIXEL_WIDTH (f);
+  height = FRAME_PIXEL_HEIGHT (f);
+
+  block_input ();
+#ifdef CAIRO_HAS_PDF_SURFACE
+  if (surface_type == CAIRO_SURFACE_TYPE_PDF)
+    {
+      surface = cairo_pdf_surface_create_for_stream (pgtk_cr_accumulate_data, &acc,
+                                                     width, height);
+      surface_set_size_func = cairo_pdf_surface_set_size;
+    }
+  else
+#endif
+#ifdef CAIRO_HAS_PNG_FUNCTIONS
+  if (surface_type == CAIRO_SURFACE_TYPE_IMAGE)
+    surface = cairo_image_surface_create (CAIRO_FORMAT_RGB24, width, height);
+  else
+#endif
+#ifdef CAIRO_HAS_PS_SURFACE
+  if (surface_type == CAIRO_SURFACE_TYPE_PS)
+    {
+      surface = cairo_ps_surface_create_for_stream (pgtk_cr_accumulate_data, &acc,
+                                                    width, height);
+      surface_set_size_func = cairo_ps_surface_set_size;
+    }
+  else
+#endif
+#ifdef CAIRO_HAS_SVG_SURFACE
+  if (surface_type == CAIRO_SURFACE_TYPE_SVG)
+    surface = cairo_svg_surface_create_for_stream (pgtk_cr_accumulate_data, &acc,
+                                                   width, height);
+  else
+#endif
+    abort ();
+
+  cr = cairo_create (surface);
+  cairo_surface_destroy (surface);
+  record_unwind_protect_ptr (pgtk_cr_destroy, cr);
+
+  while (1)
+    {
+      cairo_t *saved_cr = FRAME_CR_CONTEXT (f);
+      FRAME_CR_CONTEXT (f) = cr;
+      pgtk_clear_area (f, 0, 0, width, height);
+      expose_frame (f, 0, 0, width, height);
+      FRAME_CR_CONTEXT (f) = saved_cr;
+
+      if (NILP (frames))
+        break;
+
+      cairo_surface_show_page (surface);
+      f = XFRAME (XCAR (frames));
+      frames = XCDR (frames);
+      width = FRAME_PIXEL_WIDTH (f);
+      height = FRAME_PIXEL_HEIGHT (f);
+      if (surface_set_size_func)
+        (*surface_set_size_func) (surface, width, height);
+
+      unblock_input ();
+      maybe_quit ();
+      block_input ();
+    }
+
+#ifdef CAIRO_HAS_PNG_FUNCTIONS
+  if (surface_type == CAIRO_SURFACE_TYPE_IMAGE)
+    {
+      cairo_surface_flush (surface);
+      cairo_surface_write_to_png_stream (surface, pgtk_cr_accumulate_data, &acc);
+    }
+#endif
+  unblock_input ();
+
+  unbind_to (count, Qnil);
+
+  return CALLN (Fapply, intern ("concat"), Fnreverse (acc));
+}
+
+
 void
 init_pgtkterm (void)
 {
diff --git a/src/pgtkterm.h b/src/pgtkterm.h
index f4d6ee035f1..cff16332921 100644
--- a/src/pgtkterm.h
+++ b/src/pgtkterm.h
@@ -28,6 +28,16 @@ along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.  */
 
 #include <gtk/gtk.h>
 
+#ifdef CAIRO_HAS_PDF_SURFACE
+#include <cairo-pdf.h>
+#endif
+#ifdef CAIRO_HAS_PS_SURFACE
+#include <cairo-ps.h>
+#endif
+#ifdef CAIRO_HAS_SVG_SURFACE
+#include <cairo-svg.h>
+#endif
+
 // #define PGTK_DEBUG 1
 
 #ifdef PGTK_DEBUG
@@ -574,6 +584,7 @@ extern void pgtk_set_cr_source_with_color (struct frame *f,
                                            unsigned long color);
 extern void pgtk_cr_draw_frame (cairo_t * cr, struct frame *f);
 extern void pgtk_cr_destroy_frame_context (struct frame *f);
+extern Lisp_Object pgtk_cr_export_frames (Lisp_Object frames, cairo_surface_type_t surface_type);
 
 /* Defined in pgtkmenu.c */
 extern Lisp_Object pgtk_popup_dialog (struct frame *f, Lisp_Object header,