Added Fl_PostScript_File_Device

author: Jedidiah Barber <contact@jedbarber.id.au> 2025-01-04 15:20:44 +1300
committer: Jedidiah Barber <contact@jedbarber.id.au> 2025-01-04 15:20:44 +1300
commit: db6e6c0d15554879df2c4af3f1cfa903106f88c1 (patch)
tree: 56e4a1672577d5467500e65db5fad36db39b2a0b
parent: b870f2a1e8fcb956ce316e6a600d7d0625604830 (diff)
8 files changed, 1209 insertions, 2 deletions
diff --git a/doc/fl_postscript_file_device.html b/doc/fl_postscript_file_device.html
new file mode 100644
index 0000000..00a49ab
--- /dev/null
+++ b/doc/fl_postscript_file_device.html
@@ -0,0 +1,321 @@
+<!DOCTYPE html>
+
+<html lang="en">
+  <head>
+    <meta charset="utf-8">
+    <title>Fl_PostScript_File_Device Binding Map</title>
+    <link href="map.css" rel="stylesheet">
+  </head>
+
+  <body>
+
+
+<h2>Fl_PostScript_File_Device Binding Map</h2>
+
+
+<a href="index.html">Back to Index</a>
+
+
+<table class="package">
+  <tr><th colspan="2">Package name</th></tr>
+
+  <tr>
+    <td>Fl_PostScript_File_Device</td>
+    <td>FLTK.Devices.Surface.Paged.Postscript</td>
+  </tr>
+
+</table>
+
+
+
+<table class="type">
+  <tr><th colspan="2">Types</th></tr>
+
+  <tr>
+    <td>Fl_PostScript_File_Device</td>
+    <td>Postscript_File_Device</td>
+  </tr>
+
+  <tr>
+    <td>&nbsp;</td>
+    <td>Postscript_File_Device_Reference</td>
+  </tr>
+
+  <tr>
+    <td>FILE *</td>
+    <td>File_Type</td>
+  </tr>
+
+</table>
+
+
+
+<table class="type">
+  <tr><th colspan="2">Errors</th></tr>
+
+  <tr>
+    <td>int</td>
+    <td>File_Open_Error</td>
+  </tr>
+
+  <tr>
+    <td>int</td>
+    <td>File_Close_Error</td>
+  </tr>
+
+  <tr>
+    <td>int</td>
+    <td>User_Cancel_Error</td>
+  </tr>
+
+</table>
+
+
+
+<table class="function">
+  <tr><th colspan="2">Static Attributes</th></tr>
+
+  <tr>
+<td><pre>
+static const char * class_id = "Fl_PostScript_File_Device";
+</pre></td>
+<td>Deprecated, use runtime tag checks instead.</td>
+  </tr>
+
+  <tr>
+<td><pre>
+static const char * file_chooser_title = "Select a .ps file";
+</pre></td>
+<td><pre>
+function Get_File_Chooser_Title
+    return String;
+
+procedure Set_File_Chooser_Title
+       (Value : in String);
+</pre></td>
+  </tr>
+
+</table>
+
+
+
+<table class="function">
+  <tr><th colspan="2">Constructors</th></tr>
+
+  <tr>
+<td><pre>
+Fl_PostScript_File_Device();
+</pre></td>
+<td><pre>
+function Create
+    return Postscript_File_Device;
+</pre></td>
+  </tr>
+
+</table>
+
+
+
+<table class="function">
+  <tr><th colspan="2">Functions and Procedures</th></tr>
+
+  <tr>
+<td><pre>
+const char * class_name();
+</pre></td>
+<td>Deprecated, use runtime tag checks instead.</td>
+  </tr>
+
+  <tr>
+<td><pre>
+void end_job(void);
+</pre></td>
+<td><pre>
+procedure End_Job
+       (This : in out Postscript_File_Device);
+</pre></td>
+  </tr>
+
+  <tr>
+<td><pre>
+int end_page(void);
+</pre></td>
+<td><pre>
+procedure End_Page
+       (This : in out Postscript_File_Device);
+</pre></td>
+  </tr>
+
+  <tr>
+<td><pre>
+void margins(int *left, int *top, int *right, int *bottom);
+</pre></td>
+<td><pre>
+procedure Get_Margins
+       (This                     : in     Postscript_File_Device;
+        Left, Top, Right, Bottom :    out Integer);
+</pre></td>
+  </tr>
+
+  <tr>
+<td><pre>
+void origin(int *x, int *y);
+</pre></td>
+<td><pre>
+procedure Get_Origin
+       (This : in     Postscript_File_Device;
+        X, Y :    out Integer);
+</pre></td>
+  </tr>
+
+  <tr>
+<td><pre>
+void origin(int x, int y);
+</pre></td>
+<td><pre>
+procedure Set_Origin
+       (This : in out Postscript_File_Device;
+        X, Y : in     Integer);
+</pre></td>
+  </tr>
+
+  <tr>
+<td><pre>
+int printable_rect(int *w, int *h);
+</pre></td>
+<td><pre>
+procedure Get_Printable_Rect
+       (This : in     Postscript_File_Device;
+        W, H :    out Integer);
+</pre></td>
+  </tr>
+
+  <tr>
+<td><pre>
+void rotate(float angle);
+</pre></td>
+<td><pre>
+procedure Rotate
+       (This    : in out Postscript_File_Device;
+        Degrees : in     Float);
+</pre></td>
+  </tr>
+
+  <tr>
+<td><pre>
+void scale(float scale_x, float scale_y=0);
+</pre></td>
+<td><pre>
+procedure Scale
+       (This   : in out Postscript_File_Device;
+        Factor : in     Float);
+
+procedure Scale
+       (This               : in out Postscript_File_Device;
+        Factor_X, Factor_Y : in     Float);
+</pre></td>
+  </tr>
+
+  <tr>
+<td><pre>
+int start_job(FILE *ps_output, int pagecount,
+    enum Fl_Paged_Device::Page_Format format=Fl_Paged_Device::A4,
+    enum Fl_Paged_Device::Page_Layout layout=Fl_Paged_Device::PORTRAIT);
+</pre></td>
+<td><pre>
+procedure Start_Job
+       (This   : in out Postscript_File_Device;
+        Output : in     File_Type'Class;
+        Count  : in     Natural := 0;
+        Format : in     Page_Format := A4;
+        Layout : in     Page_Layout := Portrait)
+with Pre => Output.Is_Open;
+</pre></td>
+  </tr>
+
+  <tr>
+<td><pre>
+int start_job(int pagecount,
+    enum Fl_Paged_Device::Page_Format format=Fl_Paged_Device::A4,
+    enum Fl_Paged_Device::Page_Layout layout=Fl_Paged_Device::PORTRAIT);
+</pre></td>
+<td><pre>
+procedure Start_Job
+       (This   : in out Postscript_File_Device;
+        Count  : in     Natural := 0;
+        Format : in     Page_Format := A4;
+        Layout : in     Page_Layout := Portrait);
+</pre></td>
+  </tr>
+
+  <tr>
+<td><pre>
+int start_job(int pagecount, int *from, int *to);
+</pre></td>
+<td><pre>
+procedure Start_Job
+       (This  : in out Postscript_File_Device;
+        Count : in     Natural := 0);
+
+procedure Start_Job
+       (This     : in out Postscript_File_Device;
+        Count    : in     Natural := 0;
+        From, To :    out Positive);
+</pre></td>
+  </tr>
+
+  <tr>
+<td><pre>
+int start_page(void);
+</pre></td>
+<td><pre>
+procedure Start_Page
+       (This : in out Postscript_File_Device);
+</pre></td>
+  </tr>
+
+  <tr>
+<td><pre>
+void translate(int x, int y);
+</pre></td>
+<td><pre>
+procedure Translate
+       (This             : in out Postscript_File_Device;
+        Delta_X, Delta_Y : in     Integer);
+</pre></td>
+  </tr>
+
+  <tr>
+<td><pre>
+void untranslate(void);
+</pre></td>
+<td><pre>
+procedure Untranslate
+       (This : in out Postscript_File_Device);
+</pre></td>
+  </tr>
+
+</table>
+
+
+
+<table class="function">
+  <tr><th colspan="2">Protected Functions and Procedures</th></tr>
+
+  <tr>
+<td><pre>
+Fl_PostScript_Graphics_Driver * driver();
+</pre></td>
+<td><pre>
+function Get_Postscript_Driver
+       (This : in out Postscript_File_Device)
+    return FLTK.Devices.Graphics.Graphics_Driver_Reference;
+</pre></td>
+  </tr>
+
+</table>
+
+
+  </body>
+</html>
+
diff --git a/doc/index.html b/doc/index.html
index 6157396..2f1773a 100644
--- a/doc/index.html
+++ b/doc/index.html
@@ -86,7 +86,7 @@
   <li><a href="fl_pixmap.html">Fl_Pixmap</a></li>
   <li><a href="fl_png_image.html">Fl_PNG_Image</a></li>
   <li><a href="fl_pnm_image.html">Fl_PNM_Image</a></li>
-  <li>Fl_Postscript_File_Device</li>
+  <li><a href="fl_postscript_file_device.html">Fl_Postscript_File_Device</a></li>
   <li><a href="fl_preferences.html">Fl_Preferences</a></li>
   <li><a href="fl_printer.html">Fl_Printer</a></li>
   <li><a href="fl_progress.html">Fl_Progress</a></li>
@@ -144,6 +144,7 @@
   <li><a href="fl_display_device.html">FLTK.Devices.Surface.Display</a></li>
   <li><a href="fl_image_surface.html">FLTK.Devices.Surface.Image</a></li>
   <li><a href="fl_paged_device.html">FLTK.Devices.Surface.Paged</a></li>
+  <li><a href="fl_postscript_file_device.html">FLTK.Devices.Surface.Paged.Postscript</a></li>
   <li><a href="fl_printer.html">FLTK.Devices.Surface.Paged.Printers</a></li>
   <li><a href="fl_draw.html">FLTK.Draw</a></li>
   <li><a href="fl_preferences.html">FLTK.Environment</a></li>
diff --git a/progress.txt b/progress.txt
index 66f63d4..282e773 100644
--- a/progress.txt
+++ b/progress.txt
@@ -20,6 +20,7 @@ FLTK.Devices.Surface.Copy
 FLTK.Devices.Surface.Display
 FLTK.Devices.Surface.Image
 FLTK.Devices.Surface.Paged
+FLTK.Devices.Surface.Paged.Postscript
 FLTK.Devices.Surface.Paged.Printers
 FLTK.Draw
 FLTK.Environment
@@ -137,7 +138,6 @@ To-Do:
 Fl_GDI_Graphics_Driver
 Fl_GDI_Printer_Graphics_Driver
 Fl_Glut_Window
-Fl_Postscript_File_Device
 Fl_Postscript_Graphics_Driver
 Fl_Quartz_Graphics_Driver
 Fl_Sys_Menu_Bar
diff --git a/src/c_fl_postscript_file_device.cpp b/src/c_fl_postscript_file_device.cpp
new file mode 100644
index 0000000..22495dd
--- /dev/null
+++ b/src/c_fl_postscript_file_device.cpp
@@ -0,0 +1,125 @@
+
+
+//  Programmed by Jedidiah Barber
+//  Released into the public domain
+
+
+#include <FL/Fl_PostScript.H>
+#include "c_fl_postscript_file_device.h"
+
+
+
+
+//  Making available protected methods
+
+class My_PostScript_File_Device : Fl_PostScript_File_Device {
+public:
+    using Fl_PostScript_File_Device::driver;
+};
+
+
+
+
+//  Flattened C API
+
+POSTSCRIPTFILEDEVICE new_fl_postscript_file_device(void) {
+    Fl_PostScript_File_Device *p = new Fl_PostScript_File_Device();
+    return p;
+}
+
+void free_fl_postscript_file_device(POSTSCRIPTFILEDEVICE p) {
+    delete reinterpret_cast<Fl_PostScript_File_Device*>(p);
+}
+
+
+
+
+const char * fl_postscript_file_device_get_file_chooser_title() {
+    return Fl_PostScript_File_Device::file_chooser_title;
+}
+
+void fl_postscript_file_device_set_file_chooser_title(const char * v) {
+    Fl_PostScript_File_Device::file_chooser_title = v;
+}
+
+
+
+
+void * fl_postscript_file_device_get_driver(POSTSCRIPTFILEDEVICE p) {
+    return (reinterpret_cast<Fl_PostScript_File_Device*>(p)->*(&My_PostScript_File_Device::driver))();
+}
+
+
+
+
+int fl_postscript_file_device_start_job(POSTSCRIPTFILEDEVICE p, int c) {
+    return reinterpret_cast<Fl_PostScript_File_Device*>(p)->start_job(c, 0, 0);
+}
+
+int fl_postscript_file_device_start_job2(POSTSCRIPTFILEDEVICE p, int c, int * f, int * t) {
+    return reinterpret_cast<Fl_PostScript_File_Device*>(p)->start_job(c, f, t);
+}
+
+int fl_postscript_file_device_start_job3(POSTSCRIPTFILEDEVICE p, void * o, int c, int f, int l) {
+    return reinterpret_cast<Fl_PostScript_File_Device*>(p)->start_job
+        (reinterpret_cast<FILE*>(o),
+         c,
+         static_cast<Fl_Paged_Device::Page_Format>(f),
+         static_cast<Fl_Paged_Device::Page_Layout>(l));
+}
+
+int fl_postscript_file_device_start_job4(POSTSCRIPTFILEDEVICE p, int c, int f, int l) {
+    return reinterpret_cast<Fl_PostScript_File_Device*>(p)->start_job
+       (c,
+        static_cast<Fl_Paged_Device::Page_Format>(f),
+        static_cast<Fl_Paged_Device::Page_Layout>(l));
+}
+
+void fl_postscript_file_device_end_job(POSTSCRIPTFILEDEVICE p) {
+    reinterpret_cast<Fl_PostScript_File_Device*>(p)->end_job();
+}
+
+int fl_postscript_file_device_start_page(POSTSCRIPTFILEDEVICE p) {
+    return reinterpret_cast<Fl_PostScript_File_Device*>(p)->start_page();
+}
+
+int fl_postscript_file_device_end_page(POSTSCRIPTFILEDEVICE p) {
+    return reinterpret_cast<Fl_PostScript_File_Device*>(p)->end_page();
+}
+
+
+
+
+void fl_postscript_file_device_margins(POSTSCRIPTFILEDEVICE p, int * l, int * t, int * r, int * b) {
+    reinterpret_cast<Fl_PostScript_File_Device*>(p)->margins(l,t,r,b);
+}
+
+int fl_postscript_file_device_printable_rect(POSTSCRIPTFILEDEVICE p, int * w, int * h) {
+    return reinterpret_cast<Fl_PostScript_File_Device*>(p)->printable_rect(w,h);
+}
+
+void fl_postscript_file_device_get_origin(POSTSCRIPTFILEDEVICE p, int * x, int * y) {
+    reinterpret_cast<Fl_PostScript_File_Device*>(p)->origin(x,y);
+}
+
+void fl_postscript_file_device_set_origin(POSTSCRIPTFILEDEVICE p, int x, int y) {
+    reinterpret_cast<Fl_PostScript_File_Device*>(p)->origin(x,y);
+}
+
+void fl_postscript_file_device_rotate(POSTSCRIPTFILEDEVICE p, float r) {
+    reinterpret_cast<Fl_PostScript_File_Device*>(p)->rotate(r);
+}
+
+void fl_postscript_file_device_scale(POSTSCRIPTFILEDEVICE p, float x, float y) {
+    reinterpret_cast<Fl_PostScript_File_Device*>(p)->scale(x,y);
+}
+
+void fl_postscript_file_device_translate(POSTSCRIPTFILEDEVICE p, int x, int y) {
+    reinterpret_cast<Fl_PostScript_File_Device*>(p)->translate(x,y);
+}
+
+void fl_postscript_file_device_untranslate(POSTSCRIPTFILEDEVICE p) {
+    reinterpret_cast<Fl_PostScript_File_Device*>(p)->untranslate();
+}
+
+
diff --git a/src/c_fl_postscript_file_device.h b/src/c_fl_postscript_file_device.h
new file mode 100644
index 0000000..f4d6d31
--- /dev/null
+++ b/src/c_fl_postscript_file_device.h
@@ -0,0 +1,47 @@
+
+
+//  Programmed by Jedidiah Barber
+//  Released into the public domain
+
+
+#ifndef FL_POSTSCRIPT_FILE_DEVICE_GUARD
+#define FL_POSTSCRIPT_FILE_DEVICE_GUARD
+
+
+typedef void* POSTSCRIPTFILEDEVICE;
+
+
+extern "C" POSTSCRIPTFILEDEVICE new_fl_postscript_file_device(void);
+extern "C" void free_fl_postscript_file_device(POSTSCRIPTFILEDEVICE p);
+
+
+extern "C" const char * fl_postscript_file_device_get_file_chooser_title();
+extern "C" void fl_postscript_file_device_set_file_chooser_title(const char * v);
+
+
+extern "C" void * fl_postscript_file_device_get_driver(POSTSCRIPTFILEDEVICE p);
+
+
+extern "C" int fl_postscript_file_device_start_job(POSTSCRIPTFILEDEVICE p, int c);
+extern "C" int fl_postscript_file_device_start_job2(POSTSCRIPTFILEDEVICE p, int c, int * f, int * t);
+extern "C" int fl_postscript_file_device_start_job3(POSTSCRIPTFILEDEVICE p, void * o, int c, int f, int l);
+extern "C" int fl_postscript_file_device_start_job4(POSTSCRIPTFILEDEVICE p, int c, int f, int l);
+extern "C" void fl_postscript_file_device_end_job(POSTSCRIPTFILEDEVICE p);
+extern "C" int fl_postscript_file_device_start_page(POSTSCRIPTFILEDEVICE p);
+extern "C" int fl_postscript_file_device_end_page(POSTSCRIPTFILEDEVICE p);
+
+
+extern "C" void fl_postscript_file_device_margins(POSTSCRIPTFILEDEVICE p, int * l, int * t,
+    int * r, int * b);
+extern "C" int fl_postscript_file_device_printable_rect(POSTSCRIPTFILEDEVICE p, int * w, int * h);
+extern "C" void fl_postscript_file_device_get_origin(POSTSCRIPTFILEDEVICE p, int * x, int * y);
+extern "C" void fl_postscript_file_device_set_origin(POSTSCRIPTFILEDEVICE p, int x, int y);
+extern "C" void fl_postscript_file_device_rotate(POSTSCRIPTFILEDEVICE p, float r);
+extern "C" void fl_postscript_file_device_scale(POSTSCRIPTFILEDEVICE p, float x, float y);
+extern "C" void fl_postscript_file_device_translate(POSTSCRIPTFILEDEVICE p, int x, int y);
+extern "C" void fl_postscript_file_device_untranslate(POSTSCRIPTFILEDEVICE p);
+
+
+#endif
+
+
diff --git a/src/fltk-devices-surface-paged-postscript.adb b/src/fltk-devices-surface-paged-postscript.adb
new file mode 100644
index 0000000..92653cb
--- /dev/null
+++ b/src/fltk-devices-surface-paged-postscript.adb
@@ -0,0 +1,498 @@
+
+
+--  Programmed by Jedidiah Barber
+--  Released into the public domain
+
+
+with
+
+    Interfaces.C.Strings;
+
+use type
+
+    Interfaces.C.int;
+
+
+package body FLTK.Devices.Surface.Paged.Postscript is
+
+
+    ------------------------
+    --  Functions From C  --
+    ------------------------
+
+    function fopen
+           (Name, Mode : in Interfaces.C.char_array)
+        return Storage.Integer_Address;
+    pragma Import (C, fopen, "fopen");
+
+    function fclose
+           (Handle : in Storage.Integer_Address)
+        return Interfaces.C.int;
+    pragma Import (C, fclose, "fclose");
+
+
+
+
+    function new_fl_postscript_file_device
+        return Storage.Integer_Address;
+    pragma Import (C, new_fl_postscript_file_device, "new_fl_postscript_file_device");
+    pragma Inline (new_fl_postscript_file_device);
+
+    procedure free_fl_postscript_file_device
+           (P : in Storage.Integer_Address);
+    pragma Import (C, free_fl_postscript_file_device, "free_fl_postscript_file_device");
+    pragma Inline (free_fl_postscript_file_device);
+
+
+
+
+    function fl_postscript_file_device_get_file_chooser_title
+        return Interfaces.C.Strings.chars_ptr;
+    pragma Import (C, fl_postscript_file_device_get_file_chooser_title,
+        "fl_postscript_file_device_get_file_chooser_title");
+    pragma Inline (fl_postscript_file_device_get_file_chooser_title);
+
+    procedure fl_postscript_file_device_set_file_chooser_title
+           (V : in Interfaces.C.Strings.chars_ptr);
+    pragma Import (C, fl_postscript_file_device_set_file_chooser_title,
+        "fl_postscript_file_device_set_file_chooser_title");
+    pragma Inline (fl_postscript_file_device_set_file_chooser_title);
+
+
+
+
+    function fl_postscript_file_device_get_driver
+           (D : in Storage.Integer_Address)
+        return Storage.Integer_Address;
+    pragma Import (C, fl_postscript_file_device_get_driver, "fl_postscript_file_device_get_driver");
+    pragma Inline (fl_postscript_file_device_get_driver);
+
+
+
+
+    function fl_postscript_file_device_start_job
+           (D : in Storage.Integer_Address;
+            C : in Interfaces.C.int)
+        return Interfaces.C.int;
+    pragma Import (C, fl_postscript_file_device_start_job, "fl_postscript_file_device_start_job");
+    pragma Inline (fl_postscript_file_device_start_job);
+
+    function fl_postscript_file_device_start_job2
+           (D    : in     Storage.Integer_Address;
+            C    : in     Interfaces.C.int;
+            F, T :    out Interfaces.C.int)
+        return Interfaces.C.int;
+    pragma Import (C, fl_postscript_file_device_start_job2, "fl_postscript_file_device_start_job2");
+    pragma Inline (fl_postscript_file_device_start_job2);
+
+    function fl_postscript_file_device_start_job3
+           (D, O    : in Storage.Integer_Address;
+            C, F, L : in Interfaces.C.int)
+        return Interfaces.C.int;
+    pragma Import (C, fl_postscript_file_device_start_job3, "fl_postscript_file_device_start_job3");
+    pragma Inline (fl_postscript_file_device_start_job3);
+
+    function fl_postscript_file_device_start_job4
+           (D       : in Storage.Integer_Address;
+            C, F, L : in Interfaces.C.int)
+        return Interfaces.C.int;
+    pragma Import (C, fl_postscript_file_device_start_job4, "fl_postscript_file_device_start_job4");
+    pragma Inline (fl_postscript_file_device_start_job4);
+
+    procedure fl_postscript_file_device_end_job
+           (D : in Storage.Integer_Address);
+    pragma Import (C, fl_postscript_file_device_end_job, "fl_postscript_file_device_end_job");
+    pragma Inline (fl_postscript_file_device_end_job);
+
+    function fl_postscript_file_device_start_page
+           (D : in Storage.Integer_Address)
+        return Interfaces.C.int;
+    pragma Import (C, fl_postscript_file_device_start_page, "fl_postscript_file_device_start_page");
+    pragma Inline (fl_postscript_file_device_start_page);
+
+    function fl_postscript_file_device_end_page
+           (D : in Storage.Integer_Address)
+        return Interfaces.C.int;
+    pragma Import (C, fl_postscript_file_device_end_page, "fl_postscript_file_device_end_page");
+    pragma Inline (fl_postscript_file_device_end_page);
+
+
+
+
+    procedure fl_postscript_file_device_margins
+           (D          : in     Storage.Integer_Address;
+            L, T, R, B :    out Interfaces.C.int);
+    pragma Import (C, fl_postscript_file_device_margins, "fl_postscript_file_device_margins");
+    pragma Inline (fl_postscript_file_device_margins);
+
+    function fl_postscript_file_device_printable_rect
+           (D    : in     Storage.Integer_Address;
+            W, H :    out Interfaces.C.int)
+        return Interfaces.C.int;
+    pragma Import (C, fl_postscript_file_device_printable_rect,
+        "fl_postscript_file_device_printable_rect");
+    pragma Inline (fl_postscript_file_device_printable_rect);
+
+    procedure fl_postscript_file_device_get_origin
+           (D    : in     Storage.Integer_Address;
+            X, Y :    out Interfaces.C.int);
+    pragma Import (C, fl_postscript_file_device_get_origin, "fl_postscript_file_device_get_origin");
+    pragma Inline (fl_postscript_file_device_get_origin);
+
+    procedure fl_postscript_file_device_set_origin
+           (D    : in Storage.Integer_Address;
+            X, Y : in Interfaces.C.int);
+    pragma Import (C, fl_postscript_file_device_set_origin, "fl_postscript_file_device_set_origin");
+    pragma Inline (fl_postscript_file_device_set_origin);
+
+    procedure fl_postscript_file_device_rotate
+           (D : in Storage.Integer_Address;
+            R : in Interfaces.C.C_float);
+    pragma Import (C, fl_postscript_file_device_rotate, "fl_postscript_file_device_rotate");
+    pragma Inline (fl_postscript_file_device_rotate);
+
+    procedure fl_postscript_file_device_scale
+           (D    : in Storage.Integer_Address;
+            X, Y : in Interfaces.C.C_float);
+    pragma Import (C, fl_postscript_file_device_scale, "fl_postscript_file_device_scale");
+    pragma Inline (fl_postscript_file_device_scale);
+
+    procedure fl_postscript_file_device_translate
+           (D    : in Storage.Integer_Address;
+            X, Y : in Interfaces.C.int);
+    pragma Import (C, fl_postscript_file_device_translate, "fl_postscript_file_device_translate");
+    pragma Inline (fl_postscript_file_device_translate);
+
+    procedure fl_postscript_file_device_untranslate
+           (D : in Storage.Integer_Address);
+    pragma Import (C, fl_postscript_file_device_untranslate,
+        "fl_postscript_file_device_untranslate");
+    pragma Inline (fl_postscript_file_device_untranslate);
+
+
+
+
+    -----------------------------
+    --  Auxiliary Subprograms  --
+    -----------------------------
+
+    procedure Open
+           (File : in out File_Type;
+            Name : in     String)
+    is
+        Result : Storage.Integer_Address;
+    begin
+        File.Close;
+        Result := fopen
+           (Interfaces.C.To_C (Name),
+            Interfaces.C.To_C ("w"));
+        if Result = Null_Pointer then
+            raise File_Open_Error;
+        else
+            File.C_File := Result;
+            File.Open_State := True;
+        end if;
+    end Open;
+
+
+    function Is_Open
+           (File : in File_Type)
+        return Boolean is
+    begin
+        return File.Open_State;
+    end Is_Open;
+
+
+    procedure Close
+           (File : in out File_Type)
+    is
+        Result : Interfaces.C.int;
+    begin
+        if File.Is_Open then
+            Result := fclose (File.C_File);
+            if Result /= 0 then
+                raise File_Close_Error;
+            end if;
+            File.Open_State := False;
+        end if;
+    end Close;
+
+
+
+
+    -------------------
+    --  Destructors  --
+    -------------------
+
+    procedure Finalize
+           (This : in out File_Type) is
+    begin
+        This.Close;
+    end Finalize;
+
+
+    procedure Finalize
+           (This : in out Postscript_File_Device) is
+    begin
+        if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then
+            free_fl_postscript_file_device (This.Void_Ptr);
+            This.Void_Ptr := Null_Pointer;
+        end if;
+    end Finalize;
+
+
+    procedure Finalize
+           (This : in out Postscript_File_Device_Final_Controller) is
+    begin
+        Interfaces.C.Strings.Free (File_Chooser_Title);
+    end Finalize;
+
+
+
+
+    --------------------
+    --  Constructors  --
+    --------------------
+
+    package body Forge is
+
+        function Create
+            return Postscript_File_Device is
+        begin
+            return This : Postscript_File_Device do
+                This.Void_Ptr := new_fl_postscript_file_device;
+            end return;
+        end Create;
+
+    end Forge;
+
+
+
+
+    -------------------------
+    --  Static Attributes  --
+    -------------------------
+
+    function Get_File_Chooser_Title
+        return String is
+    begin
+        return Interfaces.C.Strings.Value (fl_postscript_file_device_get_file_chooser_title);
+    end Get_File_Chooser_Title;
+
+
+    procedure Set_File_Chooser_Title
+           (Value : in String) is
+    begin
+        Interfaces.C.Strings.Free (File_Chooser_Title);
+        File_Chooser_Title := Interfaces.C.Strings.New_String (Value);
+        fl_postscript_file_device_set_file_chooser_title (File_Chooser_Title);
+    end Set_File_Chooser_Title;
+
+
+
+
+    -----------------------
+    --  API Subprograms  --
+    -----------------------
+
+    function Get_Postscript_Driver
+           (This : in out Postscript_File_Device)
+        return FLTK.Devices.Graphics.Graphics_Driver_Reference is
+    begin
+        return raise Program_Error with "Get_Postscript_Driver unimplemented";
+    end Get_Postscript_Driver;
+
+
+
+
+    procedure Start_Job
+           (This  : in out Postscript_File_Device;
+            Count : in     Natural := 0) is
+    begin
+        if fl_postscript_file_device_start_job
+            (This.Void_Ptr, Interfaces.C.int (Count)) /= 0
+        then
+            raise Page_Error;
+        end if;
+    end Start_Job;
+
+
+    procedure Start_Job
+           (This     : in out Postscript_File_Device;
+            Count    : in     Natural := 0;
+            From, To :    out Positive) is
+    begin
+        if fl_postscript_file_device_start_job2
+           (This.Void_Ptr,
+            Interfaces.C.int (Count),
+            Interfaces.C.int (From),
+            Interfaces.C.int (To)) /= 0
+        then
+            raise Page_Error;
+        end if;
+    end Start_Job;
+
+
+    procedure Start_Job
+           (This   : in out Postscript_File_Device;
+            Output : in     File_Type'Class;
+            Count  : in     Natural := 0;
+            Format : in     Page_Format := A4;
+            Layout : in     Page_Layout := Portrait)
+    is
+        Code : Interfaces.C.int := fl_postscript_file_device_start_job3
+           (This.Void_Ptr,
+            Output.C_File,
+            Interfaces.C.int (Count),
+            To_Cint (Format),
+            To_Cint (Layout));
+    begin
+        if Code /= 0 then
+            raise Internal_FLTK_Error;
+        end if;
+    end Start_Job;
+
+
+    procedure Start_Job
+           (This   : in out Postscript_File_Device;
+            Count  : in     Natural := 0;
+            Format : in     Page_Format := A4;
+            Layout : in     Page_Layout := Portrait)
+    is
+        Code : Interfaces.C.int := fl_postscript_file_device_start_job4
+           (This.Void_Ptr,
+            Interfaces.C.int (Count),
+            To_Cint (Format),
+            To_Cint (Layout));
+    begin
+        case Code is
+        when 0 => null;
+        when 1 => raise User_Cancel_Error;
+        when 2 => raise File_Open_Error;
+        when others => raise Internal_FLTK_Error;
+        end case;
+    end Start_Job;
+
+
+    procedure End_Job
+           (This : in out Postscript_File_Device) is
+    begin
+        fl_postscript_file_device_end_job (This.Void_Ptr);
+    end End_Job;
+
+
+    procedure Start_Page
+           (This : in out Postscript_File_Device) is
+    begin
+        if fl_postscript_file_device_start_page (This.Void_Ptr) /= 0 then
+            raise Page_Error;
+        end if;
+    end Start_Page;
+
+
+    procedure End_Page
+           (This : in out Postscript_File_Device) is
+    begin
+        if fl_postscript_file_device_end_page (This.Void_Ptr) /= 0 then
+            raise Page_Error;
+        end if;
+    end End_Page;
+
+
+
+
+    procedure Get_Margins
+           (This                     : in     Postscript_File_Device;
+            Left, Top, Right, Bottom :    out Integer) is
+    begin
+        fl_postscript_file_device_margins
+           (This.Void_Ptr,
+            Interfaces.C.int (Left),
+            Interfaces.C.int (Top),
+            Interfaces.C.int (Right),
+            Interfaces.C.int (Bottom));
+    end Get_Margins;
+
+
+    procedure Get_Printable_Rect
+           (This : in     Postscript_File_Device;
+            W, H :    out Integer) is
+    begin
+        if fl_postscript_file_device_printable_rect
+            (This.Void_Ptr, Interfaces.C.int (W), Interfaces.C.int (H)) /= 0
+        then
+            raise Page_Error;
+        end if;
+    end Get_Printable_Rect;
+
+
+    procedure Get_Origin
+           (This : in     Postscript_File_Device;
+            X, Y :    out Integer) is
+    begin
+        fl_postscript_file_device_get_origin
+           (This.Void_Ptr,
+            Interfaces.C.int (X),
+            Interfaces.C.int (Y));
+    end Get_Origin;
+
+
+    procedure Set_Origin
+           (This : in out Postscript_File_Device;
+            X, Y : in     Integer) is
+    begin
+        fl_postscript_file_device_set_origin
+           (This.Void_Ptr,
+            Interfaces.C.int (X),
+            Interfaces.C.int (Y));
+    end Set_Origin;
+
+
+    procedure Rotate
+           (This    : in out Postscript_File_Device;
+            Degrees : in     Float) is
+    begin
+        fl_postscript_file_device_rotate (This.Void_Ptr, Interfaces.C.C_float (Degrees));
+    end Rotate;
+
+
+    procedure Scale
+           (This   : in out Postscript_File_Device;
+            Factor : in     Float) is
+    begin
+        fl_postscript_file_device_scale (This.Void_Ptr, Interfaces.C.C_float (Factor), 0.0);
+    end Scale;
+
+
+    procedure Scale
+           (This               : in out Postscript_File_Device;
+            Factor_X, Factor_Y : in     Float) is
+    begin
+        fl_postscript_file_device_scale
+           (This.Void_Ptr,
+            Interfaces.C.C_float (Factor_X),
+            Interfaces.C.C_float (Factor_Y));
+    end Scale;
+
+
+    procedure Translate
+           (This             : in out Postscript_File_Device;
+            Delta_X, Delta_Y : in     Integer) is
+    begin
+        fl_postscript_file_device_translate
+           (This.Void_Ptr,
+            Interfaces.C.int (Delta_X),
+            Interfaces.C.int (Delta_Y));
+    end Translate;
+
+
+    procedure Untranslate
+           (This : in out Postscript_File_Device) is
+    begin
+        fl_postscript_file_device_untranslate (This.Void_Ptr);
+    end Untranslate;
+
+
+end FLTK.Devices.Surface.Paged.Postscript;
+
+
diff --git a/src/fltk-devices-surface-paged-postscript.ads b/src/fltk-devices-surface-paged-postscript.ads
new file mode 100644
index 0000000..a7ea51c
--- /dev/null
+++ b/src/fltk-devices-surface-paged-postscript.ads
@@ -0,0 +1,214 @@
+
+
+--  Programmed by Jedidiah Barber
+--  Released into the public domain
+
+
+with
+
+    FLTK.Devices.Graphics;
+
+private with
+
+    Ada.Finalization,
+    Interfaces.C.Strings;
+
+
+package FLTK.Devices.Surface.Paged.Postscript is
+
+
+    type Postscript_File_Device is new Paged_Device with private;
+
+    type Postscript_File_Device_Reference (Data : not null access Postscript_File_Device'Class) is
+        limited null record with Implicit_Dereference => Data;
+
+
+    --  This will autoclose when it goes out of scope.
+    type File_Type is tagged limited private;
+
+    --  Calling this on a file already open will close it then open the new name.
+    procedure Open
+           (File : in out File_Type;
+            Name : in     String);
+
+    function Is_Open
+           (File : in File_Type)
+        return Boolean;
+
+    --  Calling this on a file already closed will have no effect.
+    procedure Close
+           (File : in out File_Type);
+
+
+    File_Open_Error   : exception;
+
+    File_Close_Error  : exception;
+
+    User_Cancel_Error : exception;
+
+
+
+
+    --  The initial Graphics_Driver this is supposed to have upon construction
+    --  is not currently implemented properly. Please wait warmly until the
+    --  binding for the Graphics sub-hierarchy is done.
+
+
+
+
+    package Forge is
+
+        function Create
+            return Postscript_File_Device;
+
+    end Forge;
+
+
+
+
+    function Get_File_Chooser_Title
+        return String;
+
+    procedure Set_File_Chooser_Title
+           (Value : in String);
+
+
+
+
+    --  Not currently implemented,
+    --  will return a Postscript_Graphics_Driver when done.
+    function Get_Postscript_Driver
+           (This : in out Postscript_File_Device)
+        return FLTK.Devices.Graphics.Graphics_Driver_Reference;
+
+
+
+
+    --  Docs say don't use this version.
+    procedure Start_Job
+           (This  : in out Postscript_File_Device;
+            Count : in     Natural := 0);
+
+    --  Docs say don't use this version.
+    procedure Start_Job
+           (This     : in out Postscript_File_Device;
+            Count    : in     Natural := 0;
+            From, To :    out Positive);
+
+    procedure Start_Job
+           (This   : in out Postscript_File_Device;
+            Output : in     File_Type'Class;
+            Count  : in     Natural := 0;
+            Format : in     Page_Format := A4;
+            Layout : in     Page_Layout := Portrait)
+    with Pre => Output.Is_Open;
+
+    procedure Start_Job
+           (This   : in out Postscript_File_Device;
+            Count  : in     Natural := 0;
+            Format : in     Page_Format := A4;
+            Layout : in     Page_Layout := Portrait);
+
+    procedure End_Job
+           (This : in out Postscript_File_Device);
+
+    procedure Start_Page
+           (This : in out Postscript_File_Device);
+
+    procedure End_Page
+           (This : in out Postscript_File_Device);
+
+
+
+
+    procedure Get_Margins
+           (This                     : in     Postscript_File_Device;
+            Left, Top, Right, Bottom :    out Integer);
+
+    procedure Get_Printable_Rect
+           (This : in     Postscript_File_Device;
+            W, H :    out Integer);
+
+    procedure Get_Origin
+           (This : in     Postscript_File_Device;
+            X, Y :    out Integer);
+
+    procedure Set_Origin
+           (This : in out Postscript_File_Device;
+            X, Y : in     Integer);
+
+    procedure Rotate
+           (This    : in out Postscript_File_Device;
+            Degrees : in     Float);
+
+    procedure Scale
+           (This   : in out Postscript_File_Device;
+            Factor : in     Float);
+
+    procedure Scale
+           (This               : in out Postscript_File_Device;
+            Factor_X, Factor_Y : in     Float);
+
+    procedure Translate
+           (This             : in out Postscript_File_Device;
+            Delta_X, Delta_Y : in     Integer);
+
+    procedure Untranslate
+           (This : in out Postscript_File_Device);
+
+
+private
+
+
+    type File_Type is new Ada.Finalization.Limited_Controlled with record
+        C_File     : Storage.Integer_Address;
+        Open_State : Boolean := False;
+    end record;
+
+    overriding procedure Finalize
+           (This : in out File_Type);
+
+
+    type Postscript_File_Device is new Paged_Device with null record;
+
+    overriding procedure Finalize
+           (This : in out Postscript_File_Device);
+
+
+    File_Chooser_Title : Interfaces.C.Strings.chars_ptr;
+
+
+    pragma Inline (Is_Open);
+
+    pragma Inline (Get_File_Chooser_Title);
+
+    pragma Inline (Get_Postscript_Driver);
+
+    pragma Inline (Start_Job);
+    pragma Inline (End_Job);
+    pragma Inline (Start_Page);
+    pragma Inline (End_Page);
+
+    pragma Inline (Get_Margins);
+    pragma Inline (Get_Printable_Rect);
+    pragma Inline (Get_Origin);
+    pragma Inline (Set_Origin);
+    pragma Inline (Rotate);
+    pragma Inline (Scale);
+    pragma Inline (Translate);
+    pragma Inline (Untranslate);
+
+
+    --  Needed to ensure chars_ptr storage is properly cleaned up
+    type Postscript_File_Device_Final_Controller is new Ada.Finalization.Limited_Controlled
+        with null record;
+
+    overriding procedure Finalize
+           (This : in out Postscript_File_Device_Final_Controller);
+
+    Cleanup : Postscript_File_Device_Final_Controller;
+
+
+end FLTK.Devices.Surface.Paged.Postscript;
+
+
diff --git a/src/fltk-devices-surface-paged-printers.ads b/src/fltk-devices-surface-paged-printers.ads
index b4beb82..c0bc34e 100644
--- a/src/fltk-devices-surface-paged-printers.ads
+++ b/src/fltk-devices-surface-paged-printers.ads
@@ -159,6 +159,7 @@ package FLTK.Devices.Surface.Paged.Printers is
 
 
 
+    --  Not currently implemented
     function Get_Original_Driver
            (This : in out Printer)
         return FLTK.Devices.Graphics.Graphics_Driver_Reference;
author	Jedidiah Barber <contact@jedbarber.id.au>	2025-01-04 15:20:44 +1300
committer	Jedidiah Barber <contact@jedbarber.id.au>	2025-01-04 15:20:44 +1300
commit	db6e6c0d15554879df2c4af3f1cfa903106f88c1 (patch)
tree	56e4a1672577d5467500e65db5fad36db39b2a0b
parent	b870f2a1e8fcb956ce316e6a600d7d0625604830 (diff)