Error/Warning/Fatal added to FLTK.Errors

7 files changed, 337 insertions, 21 deletions

diff --git a/doc/fl.html b/doc/fl.html
index 3547287..09b1a3b 100644
--- a/doc/fl.html
+++ b/doc/fl.html
@@ -26,6 +26,11 @@
 
   <tr>
     <td>&nbsp;</td>
+    <td>FLTK.Errors</td>
+  </tr>
+
+  <tr>
+    <td>&nbsp;</td>
     <td>FLTK.Event</td>
   </tr>
 
@@ -226,6 +231,89 @@
     <td>Mouse_Cursor</td>
   </tr>
 
+  <tr>
+    <td>&nbsp;</td>
+    <td>Error_Function</td>
+  </tr>
+
+</table>
+
+
+
+<table class="function">
+  <tr><th colspan="2">Attributes</th></tr>
+
+  <tr>
+<td><pre>
+static void (*atclose)(Fl_Window *, void *);
+</pre></td>
+<td>Deprecated, set the callback for the Window instead</td>
+  </tr>
+
+  <tr>
+<td><pre>
+static char const * const clipboard_image = "image";
+</pre></td>
+<td>&nbsp;</td>
+  </tr>
+
+  <tr>
+<td><pre>
+static char const * const clipboard_plain_text = "text/plain";
+</pre></td>
+<td>&nbsp;</td>
+  </tr>
+
+  <tr>
+<td><pre>
+static void (*error)(const char *, ...) = ::error;
+</pre></td>
+<td><pre>
+procedure Default_Error
+       (Message : in String);
+
+Current_Error : Error_Function := Default_Error'Access;
+</pre>(In FLTK.Errors)</td>
+  </tr>
+
+  <tr>
+<td><pre>
+static void (*fatal)(const char *, ...) = ::fatal;
+</pre></td>
+<td><pre>
+procedure Default_Fatal
+       (Message : in String);
+
+Current_Fatal : Error_Function := Default_Fatal'Access;
+</pre>(In FLTK.Errors)</td>
+  </tr>
+
+  <tr>
+<td><pre>
+static const char * const help = helpmsg + 13;
+</pre></td>
+<td>&nbsp;</td>
+  </tr>
+
+  <tr>
+<td><pre>
+static void (*idle)();
+</pre></td>
+<td>Should not be used directly</td>
+  </tr>
+
+  <tr>
+<td><pre>
+static void (*warning)(const char *, ...) = ::warning;
+</pre></td>
+<td><pre>
+procedure Default_Warning
+       (Message : in String);
+
+Current_Warning : Error_Function := Default_Warning'Access;
+</pre>(In FLTK.Errors)</td>
+  </tr>
+
 </table>
 
 
diff --git a/doc/fl_ask.html b/doc/fl_ask.html
index 078c7c8..857f5f5 100644
--- a/doc/fl_ask.html
+++ b/doc/fl_ask.html
@@ -75,20 +75,6 @@
 
   <tr>
 <td><pre>
-static void (*Fl::error)(const char *, ...) = ::error;
-</pre></td>
-<td>See FLTK.Errors</td>
-  </tr>
-
-  <tr>
-<td><pre>
-static void (*Fl::fatal)(const char *, ...) = ::fatal;
-</pre></td>
-<td>See FLTK.Errors</td>
-  </tr>
-
-  <tr>
-<td><pre>
 const char * fl_cancel = "Cancel";
 </pre></td>
 <td><pre>
@@ -152,13 +138,6 @@ procedure Set_Yes_String
 </pre></td>
   </tr>
 
-  <tr>
-<td><pre>
-static void (*Fl::warning)(const char *, ...) = ::warning;
-</pre></td>
-<td>See FLTK.Errors</td>
-  </tr>
-
 </table>
 
 
diff --git a/doc/index.html b/doc/index.html
index 071dc7c..8a6d4d8 100644
--- a/doc/index.html
+++ b/doc/index.html
@@ -145,6 +145,7 @@
   <li><a href="fl_printer.html">FLTK.Devices.Surfaces.Paged.Printers</a></li>
   <li><a href="fl_draw.html">FLTK.Draw</a></li>
   <li><a href="fl_preferences.html">FLTK.Environment</a></li>
+  <li><a href="fl.html">FLTK.Errors</a></li>
   <li><a href="fl.html">FLTK.Event</a></li>
   <li><a href="fl_help_dialog.html">FLTK.Help_Dialogs</a></li>
   <li><a href="fl_image.html">FLTK.Images</a></li>
diff --git a/src/c_fl_error.cpp b/src/c_fl_error.cpp
new file mode 100644
index 0000000..17c45a0
--- /dev/null
+++ b/src/c_fl_error.cpp
@@ -0,0 +1,87 @@
+
+
+//  Programmed by Jedidiah Barber
+//  Released into the public domain
+
+
+#include <FL/Fl.H>
+#include <stdarg.h>
+#include "c_fl_error.h"
+
+
+
+
+//  Exports from Ada
+
+extern "C" void error_warning_hook(const char * m);
+extern "C" void error_error_hook(const char * m);
+extern "C" void error_fatal_hook(const char * m);
+
+
+//  This is the size used internally in FLTK anyway
+const int bsize = 1024;
+
+
+//  Some prep needed to convert vargs to a single char*
+
+void warning_hook_prep(const char * m, ...) {
+    va_list args;
+    char buf[bsize];
+    va_start(args, m);
+    vsnprintf(buf, bsize, m, args);
+    va_end(args);
+    error_warning_hook(buf);
+}
+
+void error_hook_prep(const char * m, ...) {
+    va_list args;
+    char buf[bsize];
+    va_start(args, m);
+    vsnprintf(buf, bsize, m, args);
+    va_end(args);
+    error_error_hook(buf);
+}
+
+void fatal_hook_prep(const char * m, ...) {
+    va_list args;
+    char buf[bsize];
+    va_start(args, m);
+    vsnprintf(buf, bsize, m, args);
+    va_end(args);
+    error_fatal_hook(buf);
+}
+
+
+
+
+//  Original function pointers
+
+void (*original_warning)(const char *, ...) = Fl::warning;
+void (*original_error)(const char *, ...) = Fl::error;
+void (*original_fatal)(const char *, ...) = Fl::fatal;
+
+
+void fl_error_default_warning(const char * m) {
+    (*original_warning)(m);
+}
+
+void fl_error_default_error(const char * m) {
+    (*original_error)(m);
+}
+
+void fl_error_default_fatal(const char * m) {
+    (*original_fatal)(m);
+}
+
+
+
+
+//  Tying it all together
+
+void fl_error_set_hooks() {
+    Fl::warning = &warning_hook_prep;
+    Fl::error = &error_hook_prep;
+    Fl::fatal = &fatal_hook_prep;
+}
+
+
diff --git a/src/c_fl_error.h b/src/c_fl_error.h
new file mode 100644
index 0000000..263a42b
--- /dev/null
+++ b/src/c_fl_error.h
@@ -0,0 +1,21 @@
+
+
+//  Programmed by Jedidiah Barber
+//  Released into the public domain
+
+
+#ifndef FL_ERROR_GUARD
+#define FL_ERROR_GUARD
+
+
+extern "C" void fl_error_default_warning(const char * m);
+extern "C" void fl_error_default_error(const char * m);
+extern "C" void fl_error_default_fatal(const char * m);
+
+
+extern "C" void fl_error_set_hooks();
+
+
+#endif
+
+
diff --git a/src/fltk-errors.adb b/src/fltk-errors.adb
new file mode 100644
index 0000000..ef31002
--- /dev/null
+++ b/src/fltk-errors.adb
@@ -0,0 +1,101 @@
+
+
+--  Programmed by Jedidiah Barber
+--  Released into the public domain
+
+
+with
+
+    Interfaces.C.Strings;
+
+
+package body FLTK.Errors is
+
+
+    procedure fl_error_default_warning
+           (M : in Interfaces.C.char_array);
+    pragma Import (C, fl_error_default_warning, "fl_error_default_warning");
+    pragma Inline (fl_error_default_warning);
+
+    procedure fl_error_default_error
+           (M : in Interfaces.C.char_array);
+    pragma Import (C, fl_error_default_error, "fl_error_default_error");
+    pragma Inline (fl_error_default_error);
+
+    procedure fl_error_default_fatal
+           (M : in Interfaces.C.char_array);
+    pragma Import (C, fl_error_default_fatal, "fl_error_default_fatal");
+    pragma Inline (fl_error_default_fatal);
+
+    procedure fl_error_set_hooks;
+    pragma Import (C, fl_error_set_hooks, "fl_error_set_hooks");
+    pragma Inline (fl_error_set_hooks);
+
+
+
+
+    procedure Warning_Hook
+           (C_Mess : in Interfaces.C.Strings.chars_ptr);
+    pragma Export (C, Warning_Hook, "error_warning_hook");
+
+    procedure Warning_Hook
+           (C_Mess : in Interfaces.C.Strings.chars_ptr) is
+    begin
+        Current_Warning (Interfaces.C.Strings.Value (C_Mess));
+    end Warning_Hook;
+
+
+    procedure Error_Hook
+           (C_Mess : in Interfaces.C.Strings.chars_ptr);
+    pragma Export (C, Error_Hook, "error_error_hook");
+
+    procedure Error_Hook
+           (C_Mess : in Interfaces.C.Strings.chars_ptr) is
+    begin
+        Current_Error (Interfaces.C.Strings.Value (C_Mess));
+    end Error_Hook;
+
+
+    procedure Fatal_Hook
+           (C_Mess : in Interfaces.C.Strings.chars_ptr);
+    pragma Export (C, Fatal_Hook, "error_fatal_hook");
+
+    procedure Fatal_Hook
+           (C_Mess : in Interfaces.C.Strings.chars_ptr) is
+    begin
+        Current_Fatal (Interfaces.C.Strings.Value (C_Mess));
+    end Fatal_Hook;
+
+
+
+
+    procedure Default_Warning
+           (Message : in String) is
+    begin
+        fl_error_default_warning (Interfaces.C.To_C (Message));
+    end Default_Warning;
+
+
+    procedure Default_Error
+           (Message : in String) is
+    begin
+        fl_error_default_error (Interfaces.C.To_C (Message));
+    end Default_Error;
+
+
+    procedure Default_Fatal
+           (Message : in String) is
+    begin
+        fl_error_default_fatal (Interfaces.C.To_C (Message));
+    end Default_Fatal;
+
+
+begin
+
+
+    fl_error_set_hooks;
+
+
+end FLTK.Errors;
+
+
diff --git a/src/fltk-errors.ads b/src/fltk-errors.ads
new file mode 100644
index 0000000..6cdea54
--- /dev/null
+++ b/src/fltk-errors.ads
@@ -0,0 +1,39 @@
+
+
+--  Programmed by Jedidiah Barber
+--  Released into the public domain
+
+
+package FLTK.Errors is
+
+
+    type Error_Function is not null access procedure
+           (Message : in String);
+
+
+    procedure Default_Warning
+           (Message : in String);
+
+    procedure Default_Error
+           (Message : in String);
+
+    procedure Default_Fatal
+           (Message : in String);
+
+
+    Current_Warning : Error_Function := Default_Warning'Access;
+    Current_Error   : Error_Function := Default_Error'Access;
+    Current_Fatal   : Error_Function := Default_Fatal'Access;
+
+
+private
+
+
+    pragma Inline (Default_Warning);
+    pragma Inline (Default_Error);
+    pragma Inline (Default_Fatal);
+
+
+end FLTK.Errors;
+
+