Added Fl_PostScript_File_Device

1 files changed, 214 insertions, 0 deletions

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;
+
+