diff options
| -rw-r--r-- | doc/fl_ask.html | 185 | ||||
| -rw-r--r-- | src/c_fl_ask.cpp | 140 | ||||
| -rw-r--r-- | src/c_fl_ask.h | 49 | ||||
| -rw-r--r-- | src/c_fl_dialog.cpp | 87 | ||||
| -rw-r--r-- | src/c_fl_dialog.h | 35 | ||||
| -rw-r--r-- | src/fltk-asks.adb | 525 | ||||
| -rw-r--r-- | src/fltk-asks.ads | 119 |
7 files changed, 873 insertions, 267 deletions
diff --git a/doc/fl_ask.html b/doc/fl_ask.html index 4a2578c..078c7c8 100644 --- a/doc/fl_ask.html +++ b/doc/fl_ask.html @@ -38,7 +38,17 @@ <tr> <td> </td> - <td>Choice</td> + <td>Confirm_Result</td> + </tr> + + <tr> + <td> </td> + <td>Choice_Result</td> + </tr> + + <tr> + <td> </td> + <td>Extended_Choice_Result</td> </tr> <tr> @@ -51,6 +61,104 @@ <td>RGB_Int</td> </tr> + <tr> + <td> </td> + <td>File_Chooser_Callback</td> + </tr> + +</table> + + + +<table class="function"> + <tr><th colspan="2">Attributes</th></tr> + + <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> +function Get_Cancel_String + return String; + +procedure Set_Cancel_String + (Value : in String); +</pre></td> + </tr> + + <tr> +<td><pre> +const char * fl_close = "Close"; +</pre></td> +<td><pre> +function Get_Close_String + return String; + +procedure Set_Close_String + (Value : in String); +</pre></td> + </tr> + + <tr> +<td><pre> +const char * fl_no = "No"; +</pre></td> +<td><pre> +function Get_No_String + return String; + +procedure Set_No_String + (Value : in String); +</pre></td> + </tr> + + <tr> +<td><pre> +const char * fl_ok = "OK"; +</pre></td> +<td><pre> +function Get_OK_String + return String; + +procedure Set_OK_String + (Value : in String); +</pre></td> + </tr> + + <tr> +<td><pre> +const char * fl_yes = "Yes"; +</pre></td> +<td><pre> +function Get_Yes_String + return String; + +procedure Set_Yes_String + (Value : in String); +</pre></td> + </tr> + + <tr> +<td><pre> +static void (*Fl::warning)(const char *, ...) = ::warning; +</pre></td> +<td>See FLTK.Errors</td> + </tr> + </table> @@ -72,7 +180,7 @@ procedure Alert <td><pre> int fl_ask(const char *fmt,...); </pre></td> -<td>Present but disabled due to fl_ask being deprecated</td> +<td>Deprecated</td> </tr> <tr> @@ -81,24 +189,54 @@ void fl_beep(int type); </pre></td> <td><pre> procedure Beep - (Kind : in Beep_Kind); + (Kind : in Beep_Kind := Default_Beep); +</pre></td> + </tr> + + <tr> +<td><pre> +int fl_choice(const char *fmt, const char *b0, const char *b1, + const char *b2, ...); +</pre></td> +<td><pre> +function Choice + (Message, Button1 : in String) + return Choice_Result; + +function Choice + (Message, Button1, Button2 : in String) + return Choice_Result; + +function Choice + (Message, Button1, Button2, Button3 : in String) + return Choice_Result; </pre></td> </tr> <tr> <td><pre> -int fl_choice(const char *fmt, const char *b0, const char *b1, const char *b2,...); +int fl_choice_n(const char *fmt, const char *b0, const char *b1, + const char *b2, ...); </pre></td> <td><pre> -function Three_Way_Choice +function Extended_Choice + (Message, Button1 : in String) + return Extended_Choice_Result; + +function Extended_Choice + (Message, Button1, Button2 : in String) + return Extended_Choice_Result; + +function Extended_Choice (Message, Button1, Button2, Button3 : in String) - return Choice; + return Extended_Choice_Result; </pre></td> </tr> <tr> <td><pre> -int fl_color_chooser(const char *name, double &r, double &g, double &b, int cmode); +int fl_color_chooser(const char *name, double &r, double &g, + double &b, int cmode); </pre></td> <td><pre> function Color_Chooser @@ -106,13 +244,14 @@ function Color_Chooser R, G, B : in out RGB_Float; Mode : in FLTK.Widgets.Groups.Color_Choosers.Color_Mode := FLTK.Widgets.Groups.Color_Choosers.RGB) - return Boolean; + return Confirm_Result; </pre></td> </tr> <tr> <td><pre> -int fl_color_chooser(const char *name, uchar &r, uchar &g, uchar &b, int cmode); +int fl_color_chooser(const char *name, uchar &r, uchar &g, + uchar &b, int cmode); </pre></td> <td><pre> function Color_Chooser @@ -120,13 +259,14 @@ function Color_Chooser R, G, B : in out RGB_Int; Mode : in FLTK.Widgets.Groups.Color_Choosers.Color_Mode := FLTK.Widgets.Groups.Color_Choosers.RGB) - return Boolean; + return Confirm_Result; </pre></td> </tr> <tr> <td><pre> -char * fl_dir_chooser(const char *message, const char *fname, int relative); +char * fl_dir_chooser(const char *message, const char *fname, + int relative); </pre></td> <td><pre> function Dir_Chooser @@ -138,7 +278,8 @@ function Dir_Chooser <tr> <td><pre> -char * fl_file_chooser(const char *message, const char *pat, const char *fname, int relative); +char * fl_file_chooser(const char *message, const char *pat, + const char *fname, int relative); </pre></td> <td><pre> function File_Chooser @@ -152,19 +293,25 @@ function File_Chooser <td><pre> void fl_file_chooser_callback(void(*cb)(const char *)); </pre></td> -<td> </td> +<td><pre> +procedure Set_File_Chooser_Callback + (Func : in File_Chooser_Callback); +</pre></td> </tr> <tr> <td><pre> void fl_file_chooser_ok_label(const char *l); </pre></td> -<td> </td> +<td><pre> +procedure Set_File_Chooser_OK_String + (Value : in String); +</pre></td> </tr> <tr> <td><pre> -const char * fl_input(const char *fmt, const char *defstr,...); +const char * fl_input(const char *fmt, const char *defstr, ...); </pre></td> <td><pre> function Text_Input @@ -176,7 +323,7 @@ function Text_Input <tr> <td><pre> -void fl_message(const char *fmt,...); +void fl_message(const char *fmt, ...); </pre></td> <td><pre> procedure Message_Box @@ -200,7 +347,7 @@ procedure Set_Message_Font void fl_message_hotspot(int enable); </pre></td> <td><pre> -procedure Set_Hotspot +procedure Set_Message_Hotspot (To : in Boolean); </pre></td> </tr> @@ -210,7 +357,7 @@ procedure Set_Hotspot int fl_message_hotspot(void); </pre></td> <td><pre> -function Get_Hotspot +function Get_Message_Hotspot return Boolean; </pre></td> </tr> @@ -247,7 +394,7 @@ procedure Set_Message_Title_Default <tr> <td><pre> -const char * fl_password(const char *fmt, const char *defstr,...); +const char * fl_password(const char *fmt, const char *defstr, ...); </pre></td> <td><pre> function Password diff --git a/src/c_fl_ask.cpp b/src/c_fl_ask.cpp new file mode 100644 index 0000000..20af2e3 --- /dev/null +++ b/src/c_fl_ask.cpp @@ -0,0 +1,140 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/fl_ask.H> +#include <FL/Fl_File_Chooser.H> +#include <FL/Fl_Color_Chooser.H> +#include "c_fl_ask.h" + + + + +const char * fl_ask_get_cancel() { + return fl_cancel; +} + +void fl_ask_set_cancel(const char * v) { + fl_cancel = v; +} + +const char * fl_ask_get_close() { + return fl_close; +} + +void fl_ask_set_close(const char * v) { + fl_close = v; +} + +const char * fl_ask_get_no() { + return fl_no; +} + +void fl_ask_set_no(const char * v) { + fl_no = v; +} + +const char * fl_ask_get_ok() { + return fl_ok; +} + +void fl_ask_set_ok(const char * v) { + fl_ok = v; +} + +const char * fl_ask_get_yes() { + return fl_yes; +} + +void fl_ask_set_yes(const char * v) { + fl_yes = v; +} + + + + +void fl_ask_alert(const char * m) { + fl_alert(m); +} + +void fl_ask_beep(int b) { + fl_beep(b); +} + +int fl_ask_choice(const char * m, const char * a, const char * b, const char * c) { + return fl_choice(m, a, b, c); +} + +int fl_ask_choice_n(const char * m, const char * a, const char * b, const char * c) { + return fl_choice_n(m, a, b, c); +} + +const char * fl_ask_input(const char * m, const char * d) { + return fl_input(m, d); +} + +void fl_ask_message(const char * m) { + fl_message(m); +} + +const char * fl_ask_password(const char * m, const char * d) { + return fl_password(m, d); +} + + + + +int fl_ask_color_chooser(const char * n, double & r, double & g, double & b, int m) { + return fl_color_chooser(n, r, g, b, m); +} + +int fl_ask_color_chooser2(const char * n, uchar & r, uchar & g, uchar & b, int m) { + return fl_color_chooser(n, r, g, b, m); +} + +char * fl_ask_dir_chooser(const char * m, const char * d, int r) { + return fl_dir_chooser(m, d, r); +} + +char * fl_ask_file_chooser(const char * m, const char * p, const char * d, int r) { + return fl_file_chooser(m, p, d, r); +} + +void fl_ask_file_chooser_callback(void(*cb)(const char *)) { + fl_file_chooser_callback(cb); +} + +void fl_ask_file_chooser_ok_label(const char *l) { + fl_file_chooser_ok_label(l); +} + + + + +int fl_ask_get_message_hotspot(void) { + return fl_message_hotspot(); +} + +void fl_ask_set_message_hotspot(int v) { + fl_message_hotspot(v); +} + +void fl_ask_message_font(int f, int s) { + fl_message_font(f, s); +} + +void * fl_ask_message_icon(void) { + return fl_message_icon(); +} + +void fl_ask_message_title(const char * t) { + fl_message_title(t); +} + +void fl_ask_message_title_default(const char * t) { + fl_message_title_default(t); +} + + diff --git a/src/c_fl_ask.h b/src/c_fl_ask.h new file mode 100644 index 0000000..c1845b2 --- /dev/null +++ b/src/c_fl_ask.h @@ -0,0 +1,49 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_ASK_GUARD +#define FL_ASK_GUARD + + +extern "C" const char * fl_ask_get_cancel(); +extern "C" void fl_ask_set_cancel(const char * v); +extern "C" const char * fl_ask_get_close(); +extern "C" void fl_ask_set_close(const char * v); +extern "C" const char * fl_ask_get_no(); +extern "C" void fl_ask_set_no(const char * v); +extern "C" const char * fl_ask_get_ok(); +extern "C" void fl_ask_set_ok(const char * v); +extern "C" const char * fl_ask_get_yes(); +extern "C" void fl_ask_set_yes(const char * v); + + +extern "C" void fl_ask_alert(const char * m); +extern "C" void fl_ask_beep(int b); +extern "C" int fl_ask_choice(const char * m, const char * a, const char * b, const char * c); +extern "C" int fl_ask_choice_n(const char * m, const char * a, const char * b, const char * c); +extern "C" const char * fl_ask_input(const char * m, const char * d); +extern "C" void fl_ask_message(const char * m); +extern "C" const char * fl_ask_password(const char * m, const char * d); + + +extern "C" int fl_ask_color_chooser(const char * n, double & r, double & g, double & b, int m); +extern "C" int fl_ask_color_chooser2(const char * n, uchar & r, uchar & g, uchar & b, int m); +extern "C" char * fl_ask_dir_chooser(const char * m, const char * d, int r); +extern "C" char * fl_ask_file_chooser(const char * m, const char * p, const char * d, int r); +extern "C" void fl_ask_file_chooser_callback(void(*cb)(const char *)); +extern "C" void fl_ask_file_chooser_ok_label(const char *l); + + +extern "C" int fl_ask_get_message_hotspot(void); +extern "C" void fl_ask_set_message_hotspot(int v); +extern "C" void fl_ask_message_font(int f, int s); +extern "C" void * fl_ask_message_icon(void); +extern "C" void fl_ask_message_title(const char * t); +extern "C" void fl_ask_message_title_default(const char * t); + + +#endif + diff --git a/src/c_fl_dialog.cpp b/src/c_fl_dialog.cpp deleted file mode 100644 index f46145a..0000000 --- a/src/c_fl_dialog.cpp +++ /dev/null @@ -1,87 +0,0 @@ - - -// Programmed by Jedidiah Barber -// Released into the public domain - - -#include <FL/fl_ask.H> -#include <FL/Fl_File_Chooser.H> -#include <FL/Fl_Color_Chooser.H> -#include "c_fl_dialog.h" - - -void dialog_fl_alert(const char * m) { - fl_alert(m); -} - -//int dialog_fl_ask(const char * m) { -// return fl_ask(m); -//} - -void dialog_fl_beep(int b) { - fl_beep(b); -} - -int dialog_fl_choice(const char * m, const char * a, const char * b, const char * c) { - return fl_choice(m, a, b, c); -} - -const char * dialog_fl_input(const char * m, const char * d) { - return fl_input(m, d); -} - -void dialog_fl_message(const char * m) { - fl_message(m); -} - -const char * dialog_fl_password(const char * m, const char * d) { - return fl_password(m, d); -} - - - - -int dialog_fl_color_chooser(const char * n, double & r, double & g, double & b, int m) { - return fl_color_chooser(n, r, g, b, m); -} - -int dialog_fl_color_chooser2(const char * n, uchar & r, uchar & g, uchar & b, int m) { - return fl_color_chooser(n, r, g, b, m); -} - -char * dialog_fl_dir_chooser(const char * m, const char * d, int r) { - return fl_dir_chooser(m, d, r); -} - -char * dialog_fl_file_chooser(const char * m, const char * p, const char * d, int r) { - return fl_file_chooser(m, p, d, r); -} - - - - -int dialog_fl_get_message_hotspot(void) { - return fl_message_hotspot(); -} - -void dialog_fl_set_message_hotspot(int v) { - fl_message_hotspot(v); -} - -void dialog_fl_message_font(int f, int s) { - fl_message_font(f, s); -} - -void * dialog_fl_message_icon(void) { - return fl_message_icon(); -} - -void dialog_fl_message_title(const char * t) { - fl_message_title(t); -} - -void dialog_fl_message_title_default(const char * t) { - fl_message_title_default(t); -} - - diff --git a/src/c_fl_dialog.h b/src/c_fl_dialog.h deleted file mode 100644 index 3991249..0000000 --- a/src/c_fl_dialog.h +++ /dev/null @@ -1,35 +0,0 @@ - - -// Programmed by Jedidiah Barber -// Released into the public domain - - -#ifndef FL_DIALOG_GUARD -#define FL_DIALOG_GUARD - - -extern "C" void dialog_fl_alert(const char * m); -//extern "C" int dialog_fl_ask(const char * m); -extern "C" void dialog_fl_beep(int b); -extern "C" int dialog_fl_choice(const char * m, const char * a, const char * b, const char * c); -extern "C" const char * dialog_fl_input(const char * m, const char * d); -extern "C" void dialog_fl_message(const char * m); -extern "C" const char * dialog_fl_password(const char * m, const char * d); - - -extern "C" int dialog_fl_color_chooser(const char * n, double & r, double & g, double & b, int m); -extern "C" int dialog_fl_color_chooser2(const char * n, uchar & r, uchar & g, uchar & b, int m); -extern "C" char * dialog_fl_dir_chooser(const char * m, const char * d, int r); -extern "C" char * dialog_fl_file_chooser(const char * m, const char * p, const char * d, int r); - - -extern "C" int dialog_fl_get_message_hotspot(void); -extern "C" void dialog_fl_set_message_hotspot(int v); -extern "C" void dialog_fl_message_font(int f, int s); -extern "C" void * dialog_fl_message_icon(void); -extern "C" void dialog_fl_message_title(const char * t); -extern "C" void dialog_fl_message_title_default(const char * t); - - -#endif - diff --git a/src/fltk-asks.adb b/src/fltk-asks.adb index 880c4c8..2a70358 100644 --- a/src/fltk-asks.adb +++ b/src/fltk-asks.adb @@ -17,148 +17,427 @@ use type package body FLTK.Asks is - procedure dialog_fl_alert - (M : in Interfaces.C.char_array); - pragma Import (C, dialog_fl_alert, "dialog_fl_alert"); - pragma Inline (dialog_fl_alert); + ------------------------ + -- Functions From C -- + ------------------------ + + function fl_ask_get_cancel + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_ask_get_cancel, "fl_ask_get_cancel"); + pragma Inline (fl_ask_get_cancel); + + procedure fl_ask_set_cancel + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_ask_set_cancel, "fl_ask_set_cancel"); + pragma Inline (fl_ask_set_cancel); + + function fl_ask_get_close + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_ask_get_close, "fl_ask_get_close"); + pragma Inline (fl_ask_get_close); + + procedure fl_ask_set_close + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_ask_set_close, "fl_ask_set_close"); + pragma Inline (fl_ask_set_close); + + function fl_ask_get_no + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_ask_get_no, "fl_ask_get_no"); + pragma Inline (fl_ask_get_no); + + procedure fl_ask_set_no + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_ask_set_no, "fl_ask_set_no"); + pragma Inline (fl_ask_set_no); + + function fl_ask_get_ok + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_ask_get_ok, "fl_ask_get_ok"); + pragma Inline (fl_ask_get_ok); + + procedure fl_ask_set_ok + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_ask_set_ok, "fl_ask_set_ok"); + pragma Inline (fl_ask_set_ok); + + function fl_ask_get_yes + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_ask_get_yes, "fl_ask_get_yes"); + pragma Inline (fl_ask_get_yes); + + procedure fl_ask_set_yes + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_ask_set_yes, "fl_ask_set_yes"); + pragma Inline (fl_ask_set_yes); + + - -- function dialog_fl_ask - -- (M : in Interfaces.C.char_array) - -- return Interfaces.C.int; - -- pragma Import (C, dialog_fl_ask, "dialog_fl_ask"); - -- pragma Inline (dialog_fl_ask); - procedure dialog_fl_beep + procedure fl_ask_alert + (M : in Interfaces.C.char_array); + pragma Import (C, fl_ask_alert, "fl_ask_alert"); + pragma Inline (fl_ask_alert); + + procedure fl_ask_beep (B : in Interfaces.C.int); - pragma Import (C, dialog_fl_beep, "dialog_fl_beep"); - pragma Inline (dialog_fl_beep); + pragma Import (C, fl_ask_beep, "fl_ask_beep"); + pragma Inline (fl_ask_beep); + + function fl_ask_choice + (M, A : in Interfaces.C.char_array; + B, C : in Interfaces.C.Strings.chars_ptr) + return Interfaces.C.int; + pragma Import (C, fl_ask_choice, "fl_ask_choice"); + pragma Inline (fl_ask_choice); - function dialog_fl_choice - (M, A, B, C : in Interfaces.C.char_array) + function fl_ask_choice_n + (M, A : in Interfaces.C.char_array; + B, C : in Interfaces.C.Strings.chars_ptr) return Interfaces.C.int; - pragma Import (C, dialog_fl_choice, "dialog_fl_choice"); - pragma Inline (dialog_fl_choice); + pragma Import (C, fl_ask_choice_n, "fl_ask_choice_n"); + pragma Inline (fl_ask_choice_n); - function dialog_fl_input + function fl_ask_input (M, D : in Interfaces.C.char_array) return Interfaces.C.Strings.chars_ptr; - pragma Import (C, dialog_fl_input, "dialog_fl_input"); - pragma Inline (dialog_fl_input); + pragma Import (C, fl_ask_input, "fl_ask_input"); + pragma Inline (fl_ask_input); - procedure dialog_fl_message + procedure fl_ask_message (M : in Interfaces.C.char_array); - pragma Import (C, dialog_fl_message, "dialog_fl_message"); - pragma Inline (dialog_fl_message); + pragma Import (C, fl_ask_message, "fl_ask_message"); + pragma Inline (fl_ask_message); - function dialog_fl_password + function fl_ask_password (M, D : in Interfaces.C.char_array) return Interfaces.C.Strings.chars_ptr; - pragma Import (C, dialog_fl_password, "dialog_fl_password"); - pragma Inline (dialog_fl_password); + pragma Import (C, fl_ask_password, "fl_ask_password"); + pragma Inline (fl_ask_password); - function dialog_fl_color_chooser + function fl_ask_color_chooser (N : in Interfaces.C.char_array; R, G, B : in out Interfaces.C.double; M : in Interfaces.C.int) return Interfaces.C.int; - pragma Import (C, dialog_fl_color_chooser, "dialog_fl_color_chooser"); - pragma Inline (dialog_fl_color_chooser); + pragma Import (C, fl_ask_color_chooser, "fl_ask_color_chooser"); + pragma Inline (fl_ask_color_chooser); - function dialog_fl_color_chooser2 + function fl_ask_color_chooser2 (N : in Interfaces.C.char_array; R, G, B : in out Interfaces.C.unsigned_char; M : in Interfaces.C.int) return Interfaces.C.int; - pragma Import (C, dialog_fl_color_chooser2, "dialog_fl_color_chooser2"); - pragma Inline (dialog_fl_color_chooser2); + pragma Import (C, fl_ask_color_chooser2, "fl_ask_color_chooser2"); + pragma Inline (fl_ask_color_chooser2); - function dialog_fl_dir_chooser + function fl_ask_dir_chooser (M, D : in Interfaces.C.char_array; R : in Interfaces.C.int) return Interfaces.C.Strings.chars_ptr; - pragma Import (C, dialog_fl_dir_chooser, "dialog_fl_dir_chooser"); - pragma Inline (dialog_fl_dir_chooser); + pragma Import (C, fl_ask_dir_chooser, "fl_ask_dir_chooser"); + pragma Inline (fl_ask_dir_chooser); - function dialog_fl_file_chooser + function fl_ask_file_chooser (M, P, D : in Interfaces.C.char_array; R : in Interfaces.C.int) return Interfaces.C.Strings.chars_ptr; - pragma Import (C, dialog_fl_file_chooser, "dialog_fl_file_chooser"); - pragma Inline (dialog_fl_file_chooser); + pragma Import (C, fl_ask_file_chooser, "fl_ask_file_chooser"); + pragma Inline (fl_ask_file_chooser); + + procedure fl_ask_file_chooser_callback + (CB : in Storage.Integer_Address); + pragma Import (C, fl_ask_file_chooser_callback, "fl_ask_file_chooser_callback"); + pragma Inline (fl_ask_file_chooser_callback); + procedure fl_ask_file_chooser_ok_label + (L : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_ask_file_chooser_ok_label, "fl_ask_file_chooser_ok_label"); + pragma Inline (fl_ask_file_chooser_ok_label); - function dialog_fl_get_message_hotspot + + function fl_ask_get_message_hotspot return Interfaces.C.int; - pragma Import (C, dialog_fl_get_message_hotspot, "dialog_fl_get_message_hotspot"); - pragma Inline (dialog_fl_get_message_hotspot); + pragma Import (C, fl_ask_get_message_hotspot, "fl_ask_get_message_hotspot"); + pragma Inline (fl_ask_get_message_hotspot); - procedure dialog_fl_set_message_hotspot + procedure fl_ask_set_message_hotspot (V : in Interfaces.C.int); - pragma Import (C, dialog_fl_set_message_hotspot, "dialog_fl_set_message_hotspot"); - pragma Inline (dialog_fl_set_message_hotspot); + pragma Import (C, fl_ask_set_message_hotspot, "fl_ask_set_message_hotspot"); + pragma Inline (fl_ask_set_message_hotspot); - procedure dialog_fl_message_font + procedure fl_ask_message_font (F, S : in Interfaces.C.int); - pragma Import (C, dialog_fl_message_font, "dialog_fl_message_font"); - pragma Inline (dialog_fl_message_font); + pragma Import (C, fl_ask_message_font, "fl_ask_message_font"); + pragma Inline (fl_ask_message_font); - function dialog_fl_message_icon + function fl_ask_message_icon return Storage.Integer_Address; - pragma Import (C, dialog_fl_message_icon, "dialog_fl_message_icon"); - pragma Inline (dialog_fl_message_icon); + pragma Import (C, fl_ask_message_icon, "fl_ask_message_icon"); + pragma Inline (fl_ask_message_icon); - procedure dialog_fl_message_title + procedure fl_ask_message_title (T : in Interfaces.C.char_array); - pragma Import (C, dialog_fl_message_title, "dialog_fl_message_title"); - pragma Inline (dialog_fl_message_title); + pragma Import (C, fl_ask_message_title, "fl_ask_message_title"); + pragma Inline (fl_ask_message_title); - procedure dialog_fl_message_title_default + procedure fl_ask_message_title_default (T : in Interfaces.C.char_array); - pragma Import (C, dialog_fl_message_title_default, "dialog_fl_message_title_default"); - pragma Inline (dialog_fl_message_title_default); + pragma Import (C, fl_ask_message_title_default, "fl_ask_message_title_default"); + pragma Inline (fl_ask_message_title_default); + + + + + --------------------- + -- Callback Hook -- + --------------------- + procedure File_Chooser_Callback_Hook + (C_Str : in Interfaces.C.Strings.chars_ptr); + pragma Convention (C, File_Chooser_Callback_Hook); + procedure File_Chooser_Callback_Hook + (C_Str : in Interfaces.C.Strings.chars_ptr) is + begin + if Chooser_Func /= null then + Chooser_Func (Interfaces.C.Strings.Value (C_Str)); + end if; + end File_Chooser_Callback_Hook; + + + + + --------------- + -- Cleanup -- + --------------- + + procedure Finalize + (This : in out Dialog_String_Final_Controller) + is + use Interfaces.C.Strings; + begin + Free (Cancel_Str); + Free (Close_Str); + Free (No_Str); + Free (OK_Str); + Free (Yes_Str); + Free (Chooser_OK_Str); + end Finalize; + + + + + ------------------ + -- Attributes -- + ------------------ + + function Get_Cancel_String + return String is + begin + return Interfaces.C.Strings.Value (fl_ask_get_cancel); + end Get_Cancel_String; + + + procedure Set_Cancel_String + (Value : in String) is + begin + Interfaces.C.Strings.Free (Cancel_Str); + Cancel_Str := Interfaces.C.Strings.New_String (Value); + fl_ask_set_cancel (Cancel_Str); + end Set_Cancel_String; + + + function Get_Close_String + return String is + begin + return Interfaces.C.Strings.Value (fl_ask_get_close); + end Get_Close_String; + + + procedure Set_Close_String + (Value : in String) is + begin + Interfaces.C.Strings.Free (Close_Str); + Close_Str := Interfaces.C.Strings.New_String (Value); + fl_ask_set_close (Close_Str); + end Set_Close_String; + + + function Get_No_String + return String is + begin + return Interfaces.C.Strings.Value (fl_ask_get_no); + end Get_No_String; + + + procedure Set_No_String + (Value : in String) is + begin + Interfaces.C.Strings.Free (No_Str); + No_Str := Interfaces.C.Strings.New_String (Value); + fl_ask_set_no (No_Str); + end Set_No_String; + + + function Get_OK_String + return String is + begin + return Interfaces.C.Strings.Value (fl_ask_get_ok); + end Get_OK_String; + + + procedure Set_OK_String + (Value : in String) is + begin + Interfaces.C.Strings.Free (OK_Str); + OK_Str := Interfaces.C.Strings.New_String (Value); + fl_ask_set_ok (OK_Str); + end Set_OK_String; + + + function Get_Yes_String + return String is + begin + return Interfaces.C.Strings.Value (fl_ask_get_yes); + end Get_Yes_String; + + + procedure Set_Yes_String + (Value : in String) is + begin + Interfaces.C.Strings.Free (Yes_Str); + Yes_Str := Interfaces.C.Strings.New_String (Value); + fl_ask_set_yes (Yes_Str); + end Set_Yes_String; + + + + + ---------------------- + -- Common Dialogs -- + ---------------------- procedure Alert (Message : String) is begin - dialog_fl_alert (Interfaces.C.To_C (Message)); + fl_ask_alert (Interfaces.C.To_C (Message)); end Alert; - -- function Ask - -- (Message : in String) - -- return Boolean is - -- begin - -- return dialog_fl_ask (Interfaces.C.To_C (Message)) /= 0; - -- end Ask; - - procedure Beep - (Kind : in Beep_Kind) is + (Kind : in Beep_Kind := Default_Beep) is begin - dialog_fl_beep (Beep_Kind'Pos (Kind)); + fl_ask_beep (Beep_Kind'Pos (Kind)); end Beep; - function Three_Way_Choice + function Choice + (Message, Button1 : in String) + return Choice_Result + is + Result : Interfaces.C.int := fl_ask_choice + (Interfaces.C.To_C (Message), + Interfaces.C.To_C (Button1), + Interfaces.C.Strings.Null_Ptr, + Interfaces.C.Strings.Null_Ptr); + begin + return Choice_Result'Val (Result); + end Choice; + + + function Choice + (Message, Button1, Button2 : in String) + return Choice_Result + is + Str2 : aliased Interfaces.C.char_array := Interfaces.C.To_C (Button2); + Result : Interfaces.C.int := fl_ask_choice + (Interfaces.C.To_C (Message), + Interfaces.C.To_C (Button1), + Interfaces.C.Strings.To_Chars_Ptr (Str2'Unchecked_Access), + Interfaces.C.Strings.Null_Ptr); + begin + return Choice_Result'Val (Result); + end Choice; + + + function Choice (Message, Button1, Button2, Button3 : in String) - return Choice + return Choice_Result is - Result : Interfaces.C.int := dialog_fl_choice - (Interfaces.C.To_C (Message), - Interfaces.C.To_C (Button1), - Interfaces.C.To_C (Button2), - Interfaces.C.To_C (Button3)); + Str2 : aliased Interfaces.C.char_array := Interfaces.C.To_C (Button2); + Str3 : aliased Interfaces.C.char_array := Interfaces.C.To_C (Button3); + Result : Interfaces.C.int := fl_ask_choice + (Interfaces.C.To_C (Message), + Interfaces.C.To_C (Button1), + Interfaces.C.Strings.To_Chars_Ptr (Str2'Unchecked_Access), + Interfaces.C.Strings.To_Chars_Ptr (Str3'Unchecked_Access)); + begin + return Choice_Result'Val (Result); + end Choice; + + + function Extended_Choice + (Message, Button1 : in String) + return Extended_Choice_Result + is + Result : Interfaces.C.int := fl_ask_choice_n + (Interfaces.C.To_C (Message), + Interfaces.C.To_C (Button1), + Interfaces.C.Strings.Null_Ptr, + Interfaces.C.Strings.Null_Ptr); begin - return Choice'Val (Result); - end Three_Way_Choice; + case Result is + when -3 .. -1 => return Extended_Choice_Result'Val (Result + 6); + when 0 .. 2 => return Extended_Choice_Result'Val (Result); + when others => raise Program_Error; + end case; + end Extended_Choice; + + + function Extended_Choice + (Message, Button1, Button2 : in String) + return Extended_Choice_Result + is + Str2 : aliased Interfaces.C.char_array := Interfaces.C.To_C (Button2); + Result : Interfaces.C.int := fl_ask_choice_n + (Interfaces.C.To_C (Message), + Interfaces.C.To_C (Button1), + Interfaces.C.Strings.To_Chars_Ptr (Str2'Unchecked_Access), + Interfaces.C.Strings.Null_Ptr); + begin + case Result is + when -3 .. -1 => return Extended_Choice_Result'Val (Result + 6); + when 0 .. 2 => return Extended_Choice_Result'Val (Result); + when others => raise Program_Error; + end case; + end Extended_Choice; + + + function Extended_Choice + (Message, Button1, Button2, Button3 : in String) + return Extended_Choice_Result + is + Str2 : aliased Interfaces.C.char_array := Interfaces.C.To_C (Button2); + Str3 : aliased Interfaces.C.char_array := Interfaces.C.To_C (Button3); + Result : Interfaces.C.int := fl_ask_choice_n + (Interfaces.C.To_C (Message), + Interfaces.C.To_C (Button1), + Interfaces.C.Strings.To_Chars_Ptr (Str2'Unchecked_Access), + Interfaces.C.Strings.To_Chars_Ptr (Str3'Unchecked_Access)); + begin + case Result is + when -3 .. -1 => return Extended_Choice_Result'Val (Result + 6); + when 0 .. 2 => return Extended_Choice_Result'Val (Result); + when others => raise Program_Error; + end case; + end Extended_Choice; function Text_Input @@ -166,11 +445,11 @@ package body FLTK.Asks is Default : in String := "") return String is - Result : Interfaces.C.Strings.chars_ptr := dialog_fl_input + Result : Interfaces.C.Strings.chars_ptr := fl_ask_input (Interfaces.C.To_C (Message), Interfaces.C.To_C (Default)); begin - -- string does not need dealloc + -- Result does not need dealloc if Result = Interfaces.C.Strings.Null_Ptr then return ""; else @@ -182,7 +461,7 @@ package body FLTK.Asks is procedure Message_Box (Message : in String) is begin - dialog_fl_message (Interfaces.C.To_C (Message)); + fl_ask_message (Interfaces.C.To_C (Message)); end Message_Box; @@ -191,11 +470,11 @@ package body FLTK.Asks is Default : in String := "") return String is - Result : Interfaces.C.Strings.chars_ptr := dialog_fl_password + Result : Interfaces.C.Strings.chars_ptr := fl_ask_password (Interfaces.C.To_C (Message), Interfaces.C.To_C (Default)); begin - -- string does not need dealloc + -- Result does not need dealloc if Result = Interfaces.C.Strings.Null_Ptr then return ""; else @@ -211,19 +490,25 @@ package body FLTK.Asks is R, G, B : in out RGB_Float; Mode : in FLTK.Widgets.Groups.Color_Choosers.Color_Mode := FLTK.Widgets.Groups.Color_Choosers.RGB) - return Boolean + return Confirm_Result is C_R : Interfaces.C.double := Interfaces.C.double (R); C_G : Interfaces.C.double := Interfaces.C.double (G); C_B : Interfaces.C.double := Interfaces.C.double (B); M : Interfaces.C.int := FLTK.Widgets.Groups.Color_Choosers.Color_Mode'Pos (Mode); - Result : Boolean := dialog_fl_color_chooser - (Interfaces.C.To_C (Title), C_R, C_G, C_B, M) /= 0; + Result : Interfaces.C.int := fl_ask_color_chooser + (Interfaces.C.To_C (Title), C_R, C_G, C_B, M); begin - R := RGB_Float (C_R); - G := RGB_Float (C_G); - B := RGB_Float (C_B); - return Result; + if Result = 1 then + R := RGB_Float (C_R); + G := RGB_Float (C_G); + B := RGB_Float (C_B); + return Confirm; + elsif Result = 0 then + return Cancel; + else + raise Program_Error; + end if; end Color_Chooser; @@ -232,19 +517,25 @@ package body FLTK.Asks is R, G, B : in out RGB_Int; Mode : in FLTK.Widgets.Groups.Color_Choosers.Color_Mode := FLTK.Widgets.Groups.Color_Choosers.RGB) - return Boolean + return Confirm_Result is C_R : Interfaces.C.unsigned_char := Interfaces.C.unsigned_char (R); C_G : Interfaces.C.unsigned_char := Interfaces.C.unsigned_char (G); C_B : Interfaces.C.unsigned_char := Interfaces.C.unsigned_char (B); M : Interfaces.C.int := FLTK.Widgets.Groups.Color_Choosers.Color_Mode'Pos (Mode); - Result : Boolean := dialog_fl_color_chooser2 - (Interfaces.C.To_C (Title), C_R, C_G, C_B, M) /= 0; + Result : Interfaces.C.int := fl_ask_color_chooser2 + (Interfaces.C.To_C (Title), C_R, C_G, C_B, M); begin - R := RGB_Int (C_R); - G := RGB_Int (C_G); - B := RGB_Int (C_B); - return Result; + if Result = 1 then + R := RGB_Int (C_R); + G := RGB_Int (C_G); + B := RGB_Int (C_B); + return Confirm; + elsif Result = 0 then + return Cancel; + else + raise Program_Error; + end if; end Color_Chooser; @@ -253,12 +544,12 @@ package body FLTK.Asks is Relative : in Boolean := False) return String is - Result : Interfaces.C.Strings.chars_ptr := dialog_fl_dir_chooser + Result : Interfaces.C.Strings.chars_ptr := fl_ask_dir_chooser (Interfaces.C.To_C (Message), Interfaces.C.To_C (Default), Boolean'Pos (Relative)); begin - -- I'm... fairly sure the string does not need dealloc? + -- Result does not need dealloc if Result = Interfaces.C.Strings.Null_Ptr then return ""; else @@ -272,13 +563,13 @@ package body FLTK.Asks is Relative : in Boolean := False) return String is - Result : Interfaces.C.Strings.chars_ptr := dialog_fl_file_chooser + Result : Interfaces.C.Strings.chars_ptr := fl_ask_file_chooser (Interfaces.C.To_C (Message), Interfaces.C.To_C (Filter_Pattern), Interfaces.C.To_C (Default), Boolean'Pos (Relative)); begin - -- I'm... fairly sure the string does not need dealloc? + -- Result does not need dealloc if Result = Interfaces.C.Strings.Null_Ptr then return ""; else @@ -287,27 +578,43 @@ package body FLTK.Asks is end File_Chooser; + procedure Set_File_Chooser_Callback + (Func : in File_Chooser_Callback) is + begin + Chooser_Func := Func; + end Set_File_Chooser_Callback; - function Get_Hotspot + procedure Set_File_Chooser_OK_String + (Value : in String) is + begin + Interfaces.C.Strings.Free (Chooser_OK_Str); + Chooser_OK_Str := Interfaces.C.Strings.New_String (Value); + fl_ask_file_chooser_ok_label (Chooser_OK_Str); + end Set_File_Chooser_OK_String; + + + + + function Get_Message_Hotspot return Boolean is begin - return dialog_fl_get_message_hotspot /= 0; - end Get_Hotspot; + return fl_ask_get_message_hotspot /= 0; + end Get_Message_Hotspot; - procedure Set_Hotspot + procedure Set_Message_Hotspot (To : in Boolean) is begin - dialog_fl_set_message_hotspot (Boolean'Pos (To)); - end Set_Hotspot; + fl_ask_set_message_hotspot (Boolean'Pos (To)); + end Set_Message_Hotspot; procedure Set_Message_Font (Font : in Font_Kind; Size : in Font_Size) is begin - dialog_fl_message_font (Font_Kind'Pos (Font), Interfaces.C.int (Size)); + fl_ask_message_font (Font_Kind'Pos (Font), Interfaces.C.int (Size)); end Set_Message_Font; @@ -321,14 +628,14 @@ package body FLTK.Asks is procedure Set_Message_Title (To : in String) is begin - dialog_fl_message_title (Interfaces.C.To_C (To)); + fl_ask_message_title (Interfaces.C.To_C (To)); end Set_Message_Title; procedure Set_Message_Title_Default (To : in String) is begin - dialog_fl_message_title_default (Interfaces.C.To_C (To)); + fl_ask_message_title_default (Interfaces.C.To_C (To)); end Set_Message_Title_Default; @@ -337,9 +644,11 @@ package body FLTK.Asks is begin - Wrapper (Icon_Box).Void_Ptr := dialog_fl_message_icon; + Wrapper (Icon_Box).Void_Ptr := fl_ask_message_icon; Wrapper (Icon_Box).Needs_Dealloc := False; + fl_ask_file_chooser_callback (Storage.To_Integer (File_Chooser_Callback_Hook'Address)); + end FLTK.Asks; diff --git a/src/fltk-asks.ads b/src/fltk-asks.ads index cfe0522..fc6e150 100644 --- a/src/fltk-asks.ads +++ b/src/fltk-asks.ads @@ -9,6 +9,11 @@ with FLTK.Widgets.Boxes, FLTK.Widgets.Groups.Color_Choosers; +private with + + Ada.Finalization, + Interfaces.C.Strings; + package FLTK.Asks is @@ -17,28 +22,84 @@ package FLTK.Asks is (Default_Beep, Message_Beep, Error_Beep, Question_Beep, Password_Beep, Notification_Beep); - type Choice is (First, Second, Third); + type Confirm_Result is (Cancel, Confirm); + + type Choice_Result is (First, Second, Third); + + type Extended_Choice_Result is (First, Second, Third, Blocked, Closed, Escaped); type RGB_Float is new Long_Float range 0.0 .. 1.0; type RGB_Int is mod 256; + type File_Chooser_Callback is access procedure + (Item : in String); + + + + + function Get_Cancel_String + return String; + + procedure Set_Cancel_String + (Value : in String); + + function Get_Close_String + return String; + + procedure Set_Close_String + (Value : in String); + + function Get_No_String + return String; + + procedure Set_No_String + (Value : in String); + + function Get_OK_String + return String; + + procedure Set_OK_String + (Value : in String); + + function Get_Yes_String + return String; + + procedure Set_Yes_String + (Value : in String); + procedure Alert (Message : String); - -- function Ask - -- (Message : in String) - -- return Boolean; - procedure Beep - (Kind : in Beep_Kind); + (Kind : in Beep_Kind := Default_Beep); - function Three_Way_Choice + function Choice + (Message, Button1 : in String) + return Choice_Result; + + function Choice + (Message, Button1, Button2 : in String) + return Choice_Result; + + function Choice (Message, Button1, Button2, Button3 : in String) - return Choice; + return Choice_Result; + + function Extended_Choice + (Message, Button1 : in String) + return Extended_Choice_Result; + + function Extended_Choice + (Message, Button1, Button2 : in String) + return Extended_Choice_Result; + + function Extended_Choice + (Message, Button1, Button2, Button3 : in String) + return Extended_Choice_Result; function Text_Input (Message : in String; @@ -61,14 +122,14 @@ package FLTK.Asks is R, G, B : in out RGB_Float; Mode : in FLTK.Widgets.Groups.Color_Choosers.Color_Mode := FLTK.Widgets.Groups.Color_Choosers.RGB) - return Boolean; + return Confirm_Result; function Color_Chooser (Title : in String; R, G, B : in out RGB_Int; Mode : in FLTK.Widgets.Groups.Color_Choosers.Color_Mode := FLTK.Widgets.Groups.Color_Choosers.RGB) - return Boolean; + return Confirm_Result; function Dir_Chooser (Message, Default : in String; @@ -80,13 +141,19 @@ package FLTK.Asks is Relative : in Boolean := False) return String; + procedure Set_File_Chooser_Callback + (Func : in File_Chooser_Callback); + procedure Set_File_Chooser_OK_String + (Value : in String); - function Get_Hotspot + + + function Get_Message_Hotspot return Boolean; - procedure Set_Hotspot + procedure Set_Message_Hotspot (To : in Boolean); procedure Set_Message_Font @@ -109,29 +176,45 @@ private Icon_Box : aliased FLTK.Widgets.Boxes.Box; + Cancel_Str, Close_Str, No_Str, OK_Str, Yes_Str : Interfaces.C.Strings.chars_ptr; + + Chooser_OK_Str : Interfaces.C.Strings.chars_ptr; + Chooser_Func : File_Chooser_Callback; + pragma Inline (Get_Cancel_String); + pragma Inline (Get_Close_String); + pragma Inline (Get_No_String); + pragma Inline (Get_OK_String); + pragma Inline (Get_Yes_String); + pragma Inline (Alert); - -- pragma Inline (Ask); pragma Inline (Beep); - pragma Inline (Three_Way_Choice); pragma Inline (Text_Input); pragma Inline (Message_Box); pragma Inline (Password); - pragma Inline (Color_Chooser); pragma Inline (Dir_Chooser); pragma Inline (File_Chooser); + pragma Inline (Set_File_Chooser_Callback); - - pragma Inline (Get_Hotspot); - pragma Inline (Set_Hotspot); + pragma Inline (Get_Message_Hotspot); + pragma Inline (Set_Message_Hotspot); pragma Inline (Set_Message_Font); pragma Inline (Get_Message_Icon); pragma Inline (Set_Message_Title); pragma Inline (Set_Message_Title_Default); + -- Needed to ensure chars_ptr storage is properly cleaned up + type Dialog_String_Final_Controller is new Ada.Finalization.Controlled with null record; + + overriding procedure Finalize + (This : in out Dialog_String_Final_Controller); + + Cleanup : Dialog_String_Final_Controller; + + end FLTK.Asks; |