diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/c_fl_menu.cpp | 188 | ||||
| -rw-r--r-- | src/c_fl_menu.h | 34 | ||||
| -rw-r--r-- | src/c_fl_menuitem.cpp | 158 | ||||
| -rw-r--r-- | src/c_fl_menuitem.h | 73 | ||||
| -rw-r--r-- | src/fltk-menu_items.adb | 241 | ||||
| -rw-r--r-- | src/fltk-menu_items.ads | 101 | ||||
| -rw-r--r-- | src/fltk-widgets-menus.adb | 804 | ||||
| -rw-r--r-- | src/fltk-widgets-menus.ads | 187 |
8 files changed, 1382 insertions, 404 deletions
diff --git a/src/c_fl_menu.cpp b/src/c_fl_menu.cpp index 8aa82f2..2ae9289 100644 --- a/src/c_fl_menu.cpp +++ b/src/c_fl_menu.cpp @@ -16,6 +16,8 @@ extern "C" void widget_draw_hook(void * ud); extern "C" int widget_handle_hook(void * ud, int e); +extern "C" void menu_item_callback_hook(void * cobj, void * ud); + @@ -51,142 +53,187 @@ MENU new_fl_menu(int x, int y, int w, int h, char* label) { } void free_fl_menu(MENU m) { - delete reinterpret_cast<My_Menu*>(m); + delete static_cast<My_Menu*>(m); } -int fl_menu_add(MENU m, const char * t, unsigned long s, void * c, void * u, unsigned long f) { - return reinterpret_cast<Fl_Menu_*>(m)->add(t,s,reinterpret_cast<Fl_Callback_p>(c),u,f); +int fl_menu_add(MENU m, const char * t) { + return static_cast<Fl_Menu_*>(m)->add(t); } -int fl_menu_insert(MENU m, int p, const char * t, unsigned long s, - void * c, void * u, unsigned long f) -{ - return reinterpret_cast<Fl_Menu_*>(m)->insert(p,t,s,reinterpret_cast<Fl_Callback_p>(c),u,f); +int fl_menu_add2(MENU m, const char * t, unsigned long s, void * u, unsigned long f) { + return static_cast<Fl_Menu_*>(m)->add(t, s, + u==0?0:reinterpret_cast<Fl_Callback_p>(&menu_item_callback_hook), u, f); } -void fl_menu_remove(MENU m, int p) { - reinterpret_cast<Fl_Menu_*>(m)->remove(p); +int fl_menu_add3(MENU m, const char * t, const char * s, void * u, unsigned long f) { + return static_cast<Fl_Menu_*>(m)->add(t, s, + u==0?0:reinterpret_cast<Fl_Callback_p>(&menu_item_callback_hook), u, f); } -void fl_menu_clear(MENU m) { - reinterpret_cast<Fl_Menu_*>(m)->clear(); +int fl_menu_insert(MENU m, int p, const char * t, unsigned long s, void * u, unsigned long f) { + return static_cast<Fl_Menu_*>(m)->insert(p, t, s, + u==0?0:reinterpret_cast<Fl_Callback_p>(&menu_item_callback_hook), u, f); } +int fl_menu_insert2(MENU m, int p, const char * t, const char * s, void * u, unsigned long f) { + return static_cast<Fl_Menu_*>(m)->insert(p, t, s, + u==0?0:reinterpret_cast<Fl_Callback_p>(&menu_item_callback_hook), u, f); +} +void fl_menu_copy(MENU m, void * mi) { + static_cast<Fl_Menu_*>(m)->copy(static_cast<const Fl_Menu_Item*>(mi), 0); +} +void fl_menu_set_menu(MENU m, MENU d) { + static_cast<Fl_Menu_*>(m)->menu(static_cast<Fl_Menu_*>(d)->menu()); +} -const void * fl_menu_get_item(MENU m, int i) { - return &(reinterpret_cast<Fl_Menu_*>(m)->menu()[i]); +void fl_menu_remove(MENU m, int p) { + static_cast<Fl_Menu_*>(m)->remove(p); } -const void * fl_menu_find_item(MENU m, const char * t) { - return reinterpret_cast<Fl_Menu_*>(m)->find_item(t); +void fl_menu_clear(MENU m) { + static_cast<Fl_Menu_*>(m)->clear(); } -const void * fl_menu_find_item2(MENU m, void * cb) { - // have to loop through the array manually since callbacks are stored in userdata - for (int i=0; i<fl_menu_size(m); i++) { - if (reinterpret_cast<Fl_Menu_*>(m)->menu()[i].user_data() == cb) { - return fl_menu_get_item(m,i); - } - } - return 0; +int fl_menu_clear_submenu(MENU m, int i) { + return static_cast<Fl_Menu_*>(m)->clear_submenu(i); } + + + +const void * fl_menu_get_item(MENU m, int i) { + return &(static_cast<Fl_Menu_*>(m)->menu()[i]); +} + +// find_item and find_item2 are subsumed by find_index and find_index3 +// since we need to get the index for the Ada side anyway. + int fl_menu_find_index(MENU m, const char * t) { - return reinterpret_cast<Fl_Menu_*>(m)->find_index(t); + return static_cast<Fl_Menu_*>(m)->find_index(t); } int fl_menu_find_index2(MENU m, void * i) { - return reinterpret_cast<Fl_Menu_*>(m)->find_index(reinterpret_cast<Fl_Menu_Item*>(i)); + return static_cast<Fl_Menu_*>(m)->find_index(static_cast<Fl_Menu_Item*>(i)); } int fl_menu_find_index3(MENU m, void * cb) { // have to loop through the array manually since callbacks are stored in userdata for (int i=0; i<fl_menu_size(m); i++) { - if (reinterpret_cast<Fl_Menu_*>(m)->menu()[i].user_data() == cb) { + if (static_cast<Fl_Menu_*>(m)->menu()[i].user_data() == cb) { return i; } } return -1; } +int fl_menu_item_pathname(MENU m, char * buf, int len, void * mi) { + return static_cast<Fl_Menu_*>(m)->item_pathname(buf, len, static_cast<Fl_Menu_Item*>(mi)); +} + int fl_menu_size(MENU m) { - return reinterpret_cast<Fl_Menu_*>(m)->size(); + return static_cast<Fl_Menu_*>(m)->size(); } -const void * fl_menu_mvalue(MENU m) { - return reinterpret_cast<Fl_Menu_*>(m)->mvalue(); -} +// mvalue is subsumed by value since we need to get the index for +// the Ada side anyway. const char * fl_menu_text(MENU m) { - return reinterpret_cast<Fl_Menu_*>(m)->text(); + return static_cast<Fl_Menu_*>(m)->text(); } int fl_menu_value(MENU m) { - return reinterpret_cast<Fl_Menu_*>(m)->value(); + return static_cast<Fl_Menu_*>(m)->value(); } int fl_menu_set_value(MENU m, int p) { - return reinterpret_cast<Fl_Menu_*>(m)->value(p); + return static_cast<Fl_Menu_*>(m)->value(p); } int fl_menu_set_value2(MENU m, void * i) { - return reinterpret_cast<Fl_Menu_*>(m)->value(reinterpret_cast<Fl_Menu_Item*>(i)); + return static_cast<Fl_Menu_*>(m)->value(static_cast<Fl_Menu_Item*>(i)); +} + + + + +void fl_menu_setonly(MENU m, void * mi) { + static_cast<Fl_Menu_*>(m)->setonly(static_cast<Fl_Menu_Item*>(mi)); +} + +const char * fl_menu_text2(MENU m, int i) { + return static_cast<Fl_Menu_*>(m)->text(i); +} + +void fl_menu_replace(MENU m, int i, const char * t) { + static_cast<Fl_Menu_*>(m)->replace(i, t); +} + +void fl_menu_shortcut(MENU m, int i, unsigned long s) { + static_cast<Fl_Menu_*>(m)->shortcut(i, s); +} + +unsigned long fl_menu_get_mode(MENU m, int i) { + return static_cast<Fl_Menu_*>(m)->mode(i); +} + +void fl_menu_set_mode(MENU m, int i, unsigned long f) { + static_cast<Fl_Menu_*>(m)->mode(i, f); } unsigned int fl_menu_get_textcolor(MENU m) { - return reinterpret_cast<Fl_Menu_*>(m)->textcolor(); + return static_cast<Fl_Menu_*>(m)->textcolor(); } void fl_menu_set_textcolor(MENU m, unsigned int c) { - reinterpret_cast<Fl_Menu_*>(m)->textcolor(c); + static_cast<Fl_Menu_*>(m)->textcolor(c); } int fl_menu_get_textfont(MENU m) { - return reinterpret_cast<Fl_Menu_*>(m)->textfont(); + return static_cast<Fl_Menu_*>(m)->textfont(); } void fl_menu_set_textfont(MENU m, int f) { - reinterpret_cast<Fl_Menu_*>(m)->textfont(f); + static_cast<Fl_Menu_*>(m)->textfont(f); } int fl_menu_get_textsize(MENU m) { - return reinterpret_cast<Fl_Menu_*>(m)->textsize(); + return static_cast<Fl_Menu_*>(m)->textsize(); } void fl_menu_set_textsize(MENU m, int s) { - reinterpret_cast<Fl_Menu_*>(m)->textsize(s); + static_cast<Fl_Menu_*>(m)->textsize(s); } int fl_menu_get_down_box(MENU m) { - return reinterpret_cast<Fl_Menu_*>(m)->down_box(); + return static_cast<Fl_Menu_*>(m)->down_box(); } void fl_menu_set_down_box(MENU m, int t) { - reinterpret_cast<Fl_Menu_*>(m)->down_box(static_cast<Fl_Boxtype>(t)); + static_cast<Fl_Menu_*>(m)->down_box(static_cast<Fl_Boxtype>(t)); } void fl_menu_global(MENU m) { - reinterpret_cast<Fl_Menu_*>(m)->global(); + static_cast<Fl_Menu_*>(m)->global(); } int fl_menu_measure(MENU m, int i, int *h) { // method actually belongs to Fl_Menu_Item - const Fl_Menu_Item * item = reinterpret_cast<const Fl_Menu_Item*>(fl_menu_get_item(m,i)); - return item->measure(h,reinterpret_cast<Fl_Menu_*>(m)); + const Fl_Menu_Item * item = static_cast<const Fl_Menu_Item*>(fl_menu_get_item(m,i)); + return item==0?0:item->measure(h, static_cast<Fl_Menu_*>(m)); } @@ -194,26 +241,37 @@ int fl_menu_measure(MENU m, int i, int *h) { const void * fl_menu_popup(MENU m, int x, int y, const char * t, int n) { // method actually belongs to Fl_Menu_Item - const Fl_Menu_Item * dummy = reinterpret_cast<const Fl_Menu_Item*>(fl_menu_get_item(m,0)); - const Fl_Menu_Item * item; - if (n >= 0) { - item = reinterpret_cast<const Fl_Menu_Item*>(fl_menu_get_item(m,n)); - } else { - item = 0; - } - return dummy->popup(x,y,t,item,reinterpret_cast<Fl_Menu_*>(m)); + const Fl_Menu_Item * menuhead = static_cast<const Fl_Menu_Item*>(fl_menu_get_item(m, 0)); + const Fl_Menu_Item * initial = n<0?0:static_cast<const Fl_Menu_Item*>(fl_menu_get_item(m, n)); + return menuhead->popup(x, y, t, initial, static_cast<Fl_Menu_*>(m)); } const void * fl_menu_pulldown(MENU m, int x, int y, int w, int h, int n) { // method actually belongs to Fl_Menu_Item - const Fl_Menu_Item * dummy = reinterpret_cast<const Fl_Menu_Item*>(fl_menu_get_item(m,0)); - const Fl_Menu_Item * item; - if (n >= 0) { - item = reinterpret_cast<const Fl_Menu_Item*>(fl_menu_get_item(m,n)); - } else { - item = 0; - } - return dummy->pulldown(x,y,w,h,item,reinterpret_cast<Fl_Menu_*>(m)); + const Fl_Menu_Item * menuhead = static_cast<const Fl_Menu_Item*>(fl_menu_get_item(m, 0)); + const Fl_Menu_Item * initial = n<0?0:static_cast<const Fl_Menu_Item*>(fl_menu_get_item(m, n)); + return menuhead->pulldown(x, y, w, h, initial, static_cast<Fl_Menu_*>(m)); +} + +const void * fl_menu_picked(MENU m, const void * mi) { + return static_cast<Fl_Menu_*>(m)->picked(static_cast<const Fl_Menu_Item*>(mi)); +} + +const void * fl_menu_find_shortcut(MENU m, void * ip, int a) { + // method actually belongs to Fl_Menu_Item + const Fl_Menu_Item * dummy = static_cast<const Fl_Menu_Item*>(fl_menu_get_item(m, 0)); + return dummy==0?0:dummy->find_shortcut(static_cast<int*>(ip), static_cast<bool>(a)); +} + +const void * fl_menu_test_shortcut(MENU m) { + return static_cast<Fl_Menu_*>(m)->test_shortcut(); +} + + + + +void fl_menu_size2(MENU m, int w, int h) { + static_cast<Fl_Menu_*>(m)->size(w, h); } @@ -221,8 +279,10 @@ const void * fl_menu_pulldown(MENU m, int x, int y, int w, int h, int n) { void fl_menu_draw_item(MENU m, int i, int x, int y, int w, int h, int s) { // method actually belongs to Fl_Menu_Item - const Fl_Menu_Item * item = reinterpret_cast<const Fl_Menu_Item*>(fl_menu_get_item(m,i)); - item->draw(x,y,w,h,reinterpret_cast<Fl_Menu_*>(m),s); + const Fl_Menu_Item * item = static_cast<const Fl_Menu_Item*>(fl_menu_get_item(m,i)); + if (item != 0) { + item->draw(x, y, w, h, static_cast<Fl_Menu_*>(m), s); + } } void fl_menu_draw(MENU m) { @@ -234,7 +294,7 @@ void fl_menu_draw(MENU m) { } int fl_menu_handle(MENU m, int e) { - return reinterpret_cast<My_Menu*>(m)->Fl_Menu_::handle(e); + return static_cast<My_Menu*>(m)->Fl_Menu_::handle(e); } diff --git a/src/c_fl_menu.h b/src/c_fl_menu.h index b4265aa..0b046bb 100644 --- a/src/c_fl_menu.h +++ b/src/c_fl_menu.h @@ -15,30 +15,44 @@ extern "C" MENU new_fl_menu(int x, int y, int w, int h, char* label); extern "C" void free_fl_menu(MENU m); -extern "C" int fl_menu_add(MENU m, const char * t, unsigned long s, - void * c, void * u, unsigned long f); -extern "C" int fl_menu_insert(MENU m, int p, const char * t, unsigned long s, - void * c, void * u, unsigned long f); +extern "C" int fl_menu_add(MENU m, const char * t); +extern "C" int fl_menu_add2(MENU m, const char * t, unsigned long s, void * u, unsigned long f); +extern "C" int fl_menu_add3(MENU m, const char * t, const char * s, void * u, unsigned long f); +extern "C" int fl_menu_insert(MENU m, int p, const char * t, + unsigned long s, void * u, unsigned long f); +extern "C" int fl_menu_insert2(MENU m, int p, const char * t, + const char * s, void * u, unsigned long f); +extern "C" void fl_menu_copy(MENU m, void * mi); +extern "C" void fl_menu_set_menu(MENU m, MENU d); extern "C" void fl_menu_remove(MENU m, int p); extern "C" void fl_menu_clear(MENU m); +extern "C" int fl_menu_clear_submenu(MENU m, int i); extern "C" const void * fl_menu_get_item(MENU m, int i); -extern "C" const void * fl_menu_find_item(MENU m, const char * t); -extern "C" const void * fl_menu_find_item2(MENU m, void * cb); +// find_item and find_item2 are subsumed by find_index and find_index3 extern "C" int fl_menu_find_index(MENU m, const char * t); extern "C" int fl_menu_find_index2(MENU m, void * i); extern "C" int fl_menu_find_index3(MENU m, void * cb); +extern "C" int fl_menu_item_pathname(MENU m, char * buf, int len, void * mi); extern "C" int fl_menu_size(MENU m); -extern "C" const void * fl_menu_mvalue(MENU m); +// mvalue is subsumed by value extern "C" const char * fl_menu_text(MENU m); extern "C" int fl_menu_value(MENU m); extern "C" int fl_menu_set_value(MENU m, int p); extern "C" int fl_menu_set_value2(MENU m, void * i); +extern "C" void fl_menu_setonly(MENU m, void * mi); +extern "C" const char * fl_menu_text2(MENU m, int i); +extern "C" void fl_menu_replace(MENU m, int i, const char * t); +extern "C" void fl_menu_shortcut(MENU m, int i, unsigned long s); +extern "C" unsigned long fl_menu_get_mode(MENU m, int i); +extern "C" void fl_menu_set_mode(MENU m, int i, unsigned long f); + + extern "C" unsigned int fl_menu_get_textcolor(MENU m); extern "C" void fl_menu_set_textcolor(MENU m, unsigned int c); extern "C" int fl_menu_get_textfont(MENU m); @@ -55,6 +69,12 @@ extern "C" int fl_menu_measure(MENU m, int i, int *h); extern "C" const void * fl_menu_popup(MENU m, int x, int y, const char * t, int n); extern "C" const void * fl_menu_pulldown(MENU m, int x, int y, int w, int h, int n); +extern "C" const void * fl_menu_picked(MENU m, const void * mi); +extern "C" const void * fl_menu_find_shortcut(MENU m, void * ip, int a); +extern "C" const void * fl_menu_test_shortcut(MENU m); + + +extern "C" void fl_menu_size2(MENU m, int w, int h); extern "C" void fl_menu_draw_item(MENU m, int i, int x, int y, int w, int h, int s); diff --git a/src/c_fl_menuitem.cpp b/src/c_fl_menuitem.cpp index 217b3bd..cb4ebee 100644 --- a/src/c_fl_menuitem.cpp +++ b/src/c_fl_menuitem.cpp @@ -6,157 +6,189 @@ #include <FL/Fl_Menu_Item.H> #include <FL/Fl_Widget.H> +#include <FL/Fl_Image.H> #include "c_fl_menuitem.h" +// Exports from Ada + +extern "C" void menu_item_callback_hook(void * cobj, void * ud); + + + + +// Flattened C API + +void * null_fl_menu_item() { + Fl_Menu_Item *mi = new Fl_Menu_Item; + mi->label(0); + return mi; +} + void * new_fl_menu_item(char * t, void * c, unsigned long s, unsigned long f) { Fl_Menu_Item *mi = new Fl_Menu_Item; - mi->callback(reinterpret_cast<Fl_Callback*>(c)); + mi->callback(c==0?0:reinterpret_cast<Fl_Callback_p>(&menu_item_callback_hook), c); mi->flags = static_cast<int>(f); mi->shortcut(static_cast<int>(s)); mi->label(t); return mi; } -void free_fl_menu_item(MENU_ITEM mi) { - delete reinterpret_cast<Fl_Menu_Item*>(mi); +void free_fl_menu_item(MENUITEM mi) { + delete static_cast<Fl_Menu_Item*>(mi); } -void * fl_menu_item_get_user_data(MENU_ITEM mi) { - return reinterpret_cast<Fl_Menu_Item*>(mi)->user_data(); +void * fl_menu_item_get_user_data(MENUITEM mi) { + return static_cast<Fl_Menu_Item*>(mi)->user_data(); } -void fl_menu_item_set_user_data(MENU_ITEM mi, void * c) { - reinterpret_cast<Fl_Menu_Item*>(mi)->user_data(c); +void fl_menu_item_set_callback(MENUITEM mi, void * c) { + static_cast<Fl_Menu_Item*>(mi)->callback + (c==0?0:reinterpret_cast<Fl_Callback_p>(&menu_item_callback_hook), c); } -void fl_menu_item_do_callback(MENU_ITEM mi, void * w) { - reinterpret_cast<Fl_Menu_Item*>(mi)->do_callback(reinterpret_cast<Fl_Widget*>(w)); +void fl_menu_item_do_callback(MENUITEM mi, void * w) { + static_cast<Fl_Menu_Item*>(mi)->do_callback(static_cast<Fl_Widget*>(w)); } -int fl_menu_item_checkbox(MENU_ITEM mi) { - return reinterpret_cast<Fl_Menu_Item*>(mi)->checkbox(); +int fl_menu_item_checkbox(MENUITEM mi) { + return static_cast<Fl_Menu_Item*>(mi)->checkbox(); } -int fl_menu_item_radio(MENU_ITEM mi) { - return reinterpret_cast<Fl_Menu_Item*>(mi)->radio(); +int fl_menu_item_radio(MENUITEM mi) { + return static_cast<Fl_Menu_Item*>(mi)->radio(); } -int fl_menu_item_value(MENU_ITEM mi) { - return reinterpret_cast<Fl_Menu_Item*>(mi)->value(); +int fl_menu_item_submenu(MENUITEM mi) { + return static_cast<Fl_Menu_Item*>(mi)->submenu(); } -void fl_menu_item_set(MENU_ITEM mi) { - reinterpret_cast<Fl_Menu_Item*>(mi)->set(); +int fl_menu_item_value(MENUITEM mi) { + return static_cast<Fl_Menu_Item*>(mi)->value(); } -void fl_menu_item_clear(MENU_ITEM mi) { - reinterpret_cast<Fl_Menu_Item*>(mi)->clear(); +void fl_menu_item_set(MENUITEM mi) { + static_cast<Fl_Menu_Item*>(mi)->set(); } -void fl_menu_item_setonly(MENU_ITEM mi) { - reinterpret_cast<Fl_Menu_Item*>(mi)->setonly(); +void fl_menu_item_clear(MENUITEM mi) { + static_cast<Fl_Menu_Item*>(mi)->clear(); +} + +void fl_menu_item_setonly(MENUITEM mi) { + static_cast<Fl_Menu_Item*>(mi)->setonly(); } -const char * fl_menu_item_get_label(MENU_ITEM mi) { - return reinterpret_cast<Fl_Menu_Item*>(mi)->label(); +const char * fl_menu_item_get_label(MENUITEM mi) { + return static_cast<Fl_Menu_Item*>(mi)->label(); } -void fl_menu_item_set_label(MENU_ITEM mi, const char *t) { - reinterpret_cast<Fl_Menu_Item*>(mi)->label(t); +void fl_menu_item_set_label(MENUITEM mi, const char *t) { + static_cast<Fl_Menu_Item*>(mi)->label(t); } -unsigned int fl_menu_item_get_labelcolor(MENU_ITEM mi) { - return reinterpret_cast<Fl_Menu_Item*>(mi)->labelcolor(); +void fl_menu_item_set_label2(MENUITEM mi, int k, const char * t) { + static_cast<Fl_Menu_Item*>(mi)->label(static_cast<Fl_Labeltype>(k), t); } -void fl_menu_item_set_labelcolor(MENU_ITEM mi, unsigned int c) { - reinterpret_cast<Fl_Menu_Item*>(mi)->labelcolor(c); +unsigned int fl_menu_item_get_labelcolor(MENUITEM mi) { + return static_cast<Fl_Menu_Item*>(mi)->labelcolor(); } -int fl_menu_item_get_labelfont(MENU_ITEM mi) { - return reinterpret_cast<Fl_Menu_Item*>(mi)->labelfont(); +void fl_menu_item_set_labelcolor(MENUITEM mi, unsigned int c) { + static_cast<Fl_Menu_Item*>(mi)->labelcolor(c); } -void fl_menu_item_set_labelfont(MENU_ITEM mi, int f) { - reinterpret_cast<Fl_Menu_Item*>(mi)->labelfont(f); +int fl_menu_item_get_labelfont(MENUITEM mi) { + return static_cast<Fl_Menu_Item*>(mi)->labelfont(); } -int fl_menu_item_get_labelsize(MENU_ITEM mi) { - return reinterpret_cast<Fl_Menu_Item*>(mi)->labelsize(); +void fl_menu_item_set_labelfont(MENUITEM mi, int f) { + static_cast<Fl_Menu_Item*>(mi)->labelfont(f); } -void fl_menu_item_set_labelsize(MENU_ITEM mi, int s) { - reinterpret_cast<Fl_Menu_Item*>(mi)->labelsize(s); +int fl_menu_item_get_labelsize(MENUITEM mi) { + return static_cast<Fl_Menu_Item*>(mi)->labelsize(); } -int fl_menu_item_get_labeltype(MENU_ITEM mi) { - return reinterpret_cast<Fl_Menu_Item*>(mi)->labeltype(); +void fl_menu_item_set_labelsize(MENUITEM mi, int s) { + static_cast<Fl_Menu_Item*>(mi)->labelsize(s); } -void fl_menu_item_set_labeltype(MENU_ITEM mi, int t) { - reinterpret_cast<Fl_Menu_Item*>(mi)->labeltype(static_cast<Fl_Labeltype>(t)); +int fl_menu_item_get_labeltype(MENUITEM mi) { + return static_cast<Fl_Menu_Item*>(mi)->labeltype(); } +void fl_menu_item_set_labeltype(MENUITEM mi, int t) { + static_cast<Fl_Menu_Item*>(mi)->labeltype(static_cast<Fl_Labeltype>(t)); +} -int fl_menu_item_get_shortcut(MENU_ITEM mi) { - return reinterpret_cast<Fl_Menu_Item*>(mi)->shortcut(); + +int fl_menu_item_get_shortcut(MENUITEM mi) { + return static_cast<Fl_Menu_Item*>(mi)->shortcut(); } -void fl_menu_item_set_shortcut(MENU_ITEM mi, int s) { - reinterpret_cast<Fl_Menu_Item*>(mi)->shortcut(s); +void fl_menu_item_set_shortcut(MENUITEM mi, int s) { + static_cast<Fl_Menu_Item*>(mi)->shortcut(s); } -unsigned long fl_menu_item_get_flags(MENU_ITEM mi) { - return reinterpret_cast<Fl_Menu_Item*>(mi)->flags; +unsigned long fl_menu_item_get_flags(MENUITEM mi) { + return static_cast<Fl_Menu_Item*>(mi)->flags; } -void fl_menu_item_set_flags(MENU_ITEM mi, unsigned long f) { - reinterpret_cast<Fl_Menu_Item*>(mi)->flags = f; +void fl_menu_item_set_flags(MENUITEM mi, unsigned long f) { + static_cast<Fl_Menu_Item*>(mi)->flags = f; +} + + + + +void fl_menu_item_image(MENUITEM mi, void * i) { + static_cast<Fl_Menu_Item*>(mi)->image(static_cast<Fl_Image*>(i)); } -void fl_menu_item_activate(MENU_ITEM mi) { - reinterpret_cast<Fl_Menu_Item*>(mi)->activate(); +void fl_menu_item_activate(MENUITEM mi) { + static_cast<Fl_Menu_Item*>(mi)->activate(); } -void fl_menu_item_deactivate(MENU_ITEM mi) { - reinterpret_cast<Fl_Menu_Item*>(mi)->deactivate(); +void fl_menu_item_deactivate(MENUITEM mi) { + static_cast<Fl_Menu_Item*>(mi)->deactivate(); } -void fl_menu_item_show(MENU_ITEM mi) { - reinterpret_cast<Fl_Menu_Item*>(mi)->show(); +void fl_menu_item_show(MENUITEM mi) { + static_cast<Fl_Menu_Item*>(mi)->show(); } -void fl_menu_item_hide(MENU_ITEM mi) { - reinterpret_cast<Fl_Menu_Item*>(mi)->hide(); +void fl_menu_item_hide(MENUITEM mi) { + static_cast<Fl_Menu_Item*>(mi)->hide(); } -int fl_menu_item_active(MENU_ITEM mi) { - return reinterpret_cast<Fl_Menu_Item*>(mi)->active(); +int fl_menu_item_active(MENUITEM mi) { + return static_cast<Fl_Menu_Item*>(mi)->active(); } -int fl_menu_item_visible(MENU_ITEM mi) { - return reinterpret_cast<Fl_Menu_Item*>(mi)->visible(); +int fl_menu_item_visible(MENUITEM mi) { + return static_cast<Fl_Menu_Item*>(mi)->visible(); } -int fl_menu_item_activevisible(MENU_ITEM mi) { - return reinterpret_cast<Fl_Menu_Item*>(mi)->activevisible(); +int fl_menu_item_activevisible(MENUITEM mi) { + return static_cast<Fl_Menu_Item*>(mi)->activevisible(); } diff --git a/src/c_fl_menuitem.h b/src/c_fl_menuitem.h index 665cace..eefd645 100644 --- a/src/c_fl_menuitem.h +++ b/src/c_fl_menuitem.h @@ -8,58 +8,59 @@ #define FL_MENU_ITEM_GUARD +typedef void* MENUITEM; -typedef void* MENU_ITEM; - - - - +extern "C" void * null_fl_menu_item(); extern "C" void * new_fl_menu_item(char * t, void * c, unsigned long s, unsigned long f); -extern "C" void free_fl_menu_item(MENU_ITEM mi); +extern "C" void free_fl_menu_item(MENUITEM mi); +extern "C" void * fl_menu_item_get_user_data(MENUITEM mi); +extern "C" void fl_menu_item_set_callback(MENUITEM mi, void * c); +extern "C" void fl_menu_item_do_callback(MENUITEM mi, void * w); -extern "C" void * fl_menu_item_get_user_data(MENU_ITEM mi); -extern "C" void fl_menu_item_set_user_data(MENU_ITEM mi, void * c); -extern "C" void fl_menu_item_do_callback(MENU_ITEM mi, void * w); +extern "C" int fl_menu_item_checkbox(MENUITEM mi); +extern "C" int fl_menu_item_radio(MENUITEM mi); +extern "C" int fl_menu_item_submenu(MENUITEM mi); +extern "C" int fl_menu_item_value(MENUITEM mi); +extern "C" void fl_menu_item_set(MENUITEM mi); +extern "C" void fl_menu_item_clear(MENUITEM mi); +extern "C" void fl_menu_item_setonly(MENUITEM mi); -extern "C" int fl_menu_item_checkbox(MENU_ITEM mi); -extern "C" int fl_menu_item_radio(MENU_ITEM mi); -extern "C" int fl_menu_item_value(MENU_ITEM mi); -extern "C" void fl_menu_item_set(MENU_ITEM mi); -extern "C" void fl_menu_item_clear(MENU_ITEM mi); -extern "C" void fl_menu_item_setonly(MENU_ITEM mi); +extern "C" const char * fl_menu_item_get_label(MENUITEM mi); +extern "C" void fl_menu_item_set_label(MENUITEM mi, const char *t); +extern "C" void fl_menu_item_set_label2(MENUITEM mi, int k, const char * t); +extern "C" unsigned int fl_menu_item_get_labelcolor(MENUITEM mi); +extern "C" void fl_menu_item_set_labelcolor(MENUITEM mi, unsigned int c); +extern "C" int fl_menu_item_get_labelfont(MENUITEM mi); +extern "C" void fl_menu_item_set_labelfont(MENUITEM mi, int f); +extern "C" int fl_menu_item_get_labelsize(MENUITEM mi); +extern "C" void fl_menu_item_set_labelsize(MENUITEM mi, int s); +extern "C" int fl_menu_item_get_labeltype(MENUITEM mi); +extern "C" void fl_menu_item_set_labeltype(MENUITEM mi, int t); -extern "C" const char * fl_menu_item_get_label(MENU_ITEM mi); -extern "C" void fl_menu_item_set_label(MENU_ITEM mi, const char *t); -extern "C" unsigned int fl_menu_item_get_labelcolor(MENU_ITEM mi); -extern "C" void fl_menu_item_set_labelcolor(MENU_ITEM mi, unsigned int c); -extern "C" int fl_menu_item_get_labelfont(MENU_ITEM mi); -extern "C" void fl_menu_item_set_labelfont(MENU_ITEM mi, int f); -extern "C" int fl_menu_item_get_labelsize(MENU_ITEM mi); -extern "C" void fl_menu_item_set_labelsize(MENU_ITEM mi, int s); -extern "C" int fl_menu_item_get_labeltype(MENU_ITEM mi); -extern "C" void fl_menu_item_set_labeltype(MENU_ITEM mi, int t); +extern "C" int fl_menu_item_get_shortcut(MENUITEM mi); +extern "C" void fl_menu_item_set_shortcut(MENUITEM mi, int s); +extern "C" unsigned long fl_menu_item_get_flags(MENUITEM mi); +extern "C" void fl_menu_item_set_flags(MENUITEM mi, unsigned long f); -extern "C" int fl_menu_item_get_shortcut(MENU_ITEM mi); -extern "C" void fl_menu_item_set_shortcut(MENU_ITEM mi, int s); -extern "C" unsigned long fl_menu_item_get_flags(MENU_ITEM mi); -extern "C" void fl_menu_item_set_flags(MENU_ITEM mi, unsigned long f); +extern "C" void fl_menu_item_image(MENUITEM mi, void * i); -extern "C" void fl_menu_item_activate(MENU_ITEM mi); -extern "C" void fl_menu_item_deactivate(MENU_ITEM mi); -extern "C" void fl_menu_item_show(MENU_ITEM mi); -extern "C" void fl_menu_item_hide(MENU_ITEM mi); -extern "C" int fl_menu_item_active(MENU_ITEM mi); -extern "C" int fl_menu_item_visible(MENU_ITEM mi); -extern "C" int fl_menu_item_activevisible(MENU_ITEM mi); +extern "C" void fl_menu_item_activate(MENUITEM mi); +extern "C" void fl_menu_item_deactivate(MENUITEM mi); +extern "C" void fl_menu_item_show(MENUITEM mi); +extern "C" void fl_menu_item_hide(MENUITEM mi); +extern "C" int fl_menu_item_active(MENUITEM mi); +extern "C" int fl_menu_item_visible(MENUITEM mi); +extern "C" int fl_menu_item_activevisible(MENUITEM mi); #endif + diff --git a/src/fltk-menu_items.adb b/src/fltk-menu_items.adb index b93f1f5..2acaeeb 100644 --- a/src/fltk-menu_items.adb +++ b/src/fltk-menu_items.adb @@ -45,10 +45,10 @@ package body FLTK.Menu_Items is pragma Import (C, fl_menu_item_get_user_data, "fl_menu_item_get_user_data"); pragma Inline (fl_menu_item_get_user_data); - procedure fl_menu_item_set_user_data + procedure fl_menu_item_set_callback (MI, C : in Storage.Integer_Address); - pragma Import (C, fl_menu_item_set_user_data, "fl_menu_item_set_user_data"); - pragma Inline (fl_menu_item_set_user_data); + pragma Import (C, fl_menu_item_set_callback, "fl_menu_item_set_callback"); + pragma Inline (fl_menu_item_set_callback); procedure fl_menu_item_do_callback (MI, W : in Storage.Integer_Address); @@ -70,6 +70,12 @@ package body FLTK.Menu_Items is pragma Import (C, fl_menu_item_radio, "fl_menu_item_radio"); pragma Inline (fl_menu_item_radio); + function fl_menu_item_submenu + (MI : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_menu_item_submenu, "fl_menu_item_submenu"); + pragma Inline (fl_menu_item_submenu); + function fl_menu_item_value (MI : in Storage.Integer_Address) return Interfaces.C.int; @@ -106,6 +112,13 @@ package body FLTK.Menu_Items is pragma Import (C, fl_menu_item_set_label, "fl_menu_item_set_label"); pragma Inline (fl_menu_item_set_label); + procedure fl_menu_item_set_label2 + (MI : in Storage.Integer_Address; + K : in Interfaces.C.int; + T : in Interfaces.C.char_array); + pragma Import (C, fl_menu_item_set_label2, "fl_menu_item_set_label2"); + pragma Inline (fl_menu_item_set_label2); + function fl_menu_item_get_labelcolor (MI : in Storage.Integer_Address) return Interfaces.C.unsigned; @@ -184,6 +197,14 @@ package body FLTK.Menu_Items is + procedure fl_menu_item_image + (MI, I : in Storage.Integer_Address); + pragma Import (C, fl_menu_item_image, "fl_menu_item_image"); + pragma Inline (fl_menu_item_image); + + + + procedure fl_menu_item_activate (MI : in Storage.Integer_Address); pragma Import (C, fl_menu_item_activate, "fl_menu_item_activate"); @@ -246,8 +267,8 @@ package body FLTK.Menu_Items is Flags : in Menu_Flag := Flag_Normal) return Menu_Item is begin - return Item : Menu_Item do - Item.Void_Ptr := new_fl_menu_item + return This : Menu_Item do + This.Void_Ptr := new_fl_menu_item (Interfaces.C.To_C (Text), Callback_Convert.To_Address (Action), To_C (Shortcut), @@ -263,79 +284,106 @@ package body FLTK.Menu_Items is function Get_Callback - (Item : in Menu_Item) + (This : in Menu_Item) return FLTK.Widgets.Widget_Callback is begin - return Callback_Convert.To_Access (fl_menu_item_get_user_data (Item.Void_Ptr)); + return Callback_Convert.To_Access (fl_menu_item_get_user_data (This.Void_Ptr)); end Get_Callback; procedure Set_Callback - (Item : in out Menu_Item; + (This : in out Menu_Item; Func : in FLTK.Widgets.Widget_Callback) is begin - fl_menu_item_set_user_data - (Item.Void_Ptr, + -- Coordinating callback vs userdata is done in C++ + fl_menu_item_set_callback + (This.Void_Ptr, Callback_Convert.To_Address (Func)); end Set_Callback; procedure Do_Callback - (Item : in out Menu_Item; + (This : in out Menu_Item; Widget : in out FLTK.Widgets.Widget'Class) is begin - fl_menu_item_do_callback (Item.Void_Ptr, Wrapper (Widget).Void_Ptr); + fl_menu_item_do_callback (This.Void_Ptr, Wrapper (Widget).Void_Ptr); end Do_Callback; function Has_Checkbox - (Item : in Menu_Item) + (This : in Menu_Item) return Boolean is begin - return fl_menu_item_checkbox (Item.Void_Ptr) /= 0; + return fl_menu_item_checkbox (This.Void_Ptr) /= 0; end Has_Checkbox; + function Is_Radio - (Item : in Menu_Item) + (This : in Menu_Item) return Boolean is begin - return fl_menu_item_radio (Item.Void_Ptr) /= 0; + return fl_menu_item_radio (This.Void_Ptr) /= 0; end Is_Radio; + + function Is_Submenu + (This : in Menu_Item) + return Boolean is + begin + return fl_menu_item_submenu (This.Void_Ptr) /= 0; + end Is_Submenu; + + function Get_State - (Item : in Menu_Item) + (This : in Menu_Item) return Boolean is begin - return fl_menu_item_value (Item.Void_Ptr) /= 0; + return fl_menu_item_value (This.Void_Ptr) /= 0; end Get_State; + procedure Set_State - (Item : in out Menu_Item; + (This : in out Menu_Item; To : in Boolean) is begin if To then - fl_menu_item_set (Item.Void_Ptr); + fl_menu_item_set (This.Void_Ptr); else - fl_menu_item_clear (Item.Void_Ptr); + fl_menu_item_clear (This.Void_Ptr); end if; end Set_State; + + procedure Set + (This : in out Menu_Item) is + begin + fl_menu_item_set (This.Void_Ptr); + end Set; + + + procedure Clear + (This : in out Menu_Item) is + begin + fl_menu_item_clear (This.Void_Ptr); + end Clear; + + procedure Set_Only - (Item : in out Menu_Item) is + (This : in out Menu_Item) is begin - fl_menu_item_setonly (Item.Void_Ptr); + fl_menu_item_setonly (This.Void_Ptr); end Set_Only; function Get_Label - (Item : in Menu_Item) + (This : in Menu_Item) return String is - Ptr : Interfaces.C.Strings.chars_ptr := fl_menu_item_get_label (Item.Void_Ptr); + Ptr : Interfaces.C.Strings.chars_ptr := fl_menu_item_get_label (This.Void_Ptr); begin if Ptr = Interfaces.C.Strings.Null_Ptr then return ""; @@ -344,156 +392,213 @@ package body FLTK.Menu_Items is end if; end Get_Label; + procedure Set_Label - (Item : in out Menu_Item; + (This : in out Menu_Item; Text : in String) is begin - fl_menu_item_set_label (Item.Void_Ptr, Interfaces.C.To_C (Text)); + fl_menu_item_set_label (This.Void_Ptr, Interfaces.C.To_C (Text)); end Set_Label; + + procedure Set_Label + (This : in out Menu_Item; + Kind : in Label_Kind; + Text : in String) is + begin + fl_menu_item_set_label2 (This.Void_Ptr, Label_Kind'Pos (Kind), Interfaces.C.To_C (Text)); + end Set_Label; + + function Get_Label_Color - (Item : in Menu_Item) + (This : in Menu_Item) return Color is begin - return Color (fl_menu_item_get_labelcolor (Item.Void_Ptr)); + return Color (fl_menu_item_get_labelcolor (This.Void_Ptr)); end Get_Label_Color; + procedure Set_Label_Color - (Item : in out Menu_Item; + (This : in out Menu_Item; To : in Color) is begin - fl_menu_item_set_labelcolor (Item.Void_Ptr, Interfaces.C.unsigned (To)); + fl_menu_item_set_labelcolor (This.Void_Ptr, Interfaces.C.unsigned (To)); end Set_Label_Color; + function Get_Label_Font - (Item : in Menu_Item) - return Font_Kind is + (This : in Menu_Item) + return Font_Kind + is + Result : Interfaces.C.int := fl_menu_item_get_labelfont (This.Void_Ptr); begin - return Font_Kind'Val (fl_menu_item_get_labelfont (Item.Void_Ptr)); + return Font_Kind'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Menu_Item::labelfont returned unexpected Font value of " & + Interfaces.C.int'Image (Result); end Get_Label_Font; + procedure Set_Label_Font - (Item : in out Menu_Item; + (This : in out Menu_Item; To : in Font_Kind) is begin - fl_menu_item_set_labelfont (Item.Void_Ptr, Font_Kind'Pos (To)); + fl_menu_item_set_labelfont (This.Void_Ptr, Font_Kind'Pos (To)); end Set_Label_Font; + function Get_Label_Size - (Item : in Menu_Item) - return Font_Size is + (This : in Menu_Item) + return Font_Size + is + Result : Interfaces.C.int := fl_menu_item_get_labelsize (This.Void_Ptr); begin - return Font_Size (fl_menu_item_get_labelsize (Item.Void_Ptr)); + return Font_Size (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Menu_Item::labelsize returned unexpected Size value of " & + Interfaces.C.int'Image (Result); end Get_Label_Size; + procedure Set_Label_Size - (Item : in out Menu_Item; + (This : in out Menu_Item; To : in Font_Size) is begin - fl_menu_item_set_labelsize (Item.Void_Ptr, Interfaces.C.int (To)); + fl_menu_item_set_labelsize (This.Void_Ptr, Interfaces.C.int (To)); end Set_Label_Size; + function Get_Label_Type - (Item : in Menu_Item) - return Label_Kind is + (This : in Menu_Item) + return Label_Kind + is + Result : Interfaces.C.int := fl_menu_item_get_labeltype (This.Void_Ptr); begin - return Label_Kind'Val (fl_menu_item_get_labeltype (Item.Void_Ptr)); + return Label_Kind'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Menu_Item::labeltype returned unexpected Kind value of " & + Interfaces.C.int'Image (Result); end Get_Label_Type; + procedure Set_Label_Type - (Item : in out Menu_Item; + (This : in out Menu_Item; To : in Label_Kind) is begin - fl_menu_item_set_labeltype (Item.Void_Ptr, Label_Kind'Pos (To)); + fl_menu_item_set_labeltype (This.Void_Ptr, Label_Kind'Pos (To)); end Set_Label_Type; function Get_Shortcut - (Item : in Menu_Item) + (This : in Menu_Item) return Key_Combo is begin - return To_Ada (Interfaces.C.unsigned_long (fl_menu_item_get_shortcut (Item.Void_Ptr))); + return To_Ada (Interfaces.C.unsigned_long (fl_menu_item_get_shortcut (This.Void_Ptr))); end Get_Shortcut; + procedure Set_Shortcut - (Item : in out Menu_Item; + (This : in out Menu_Item; To : in Key_Combo) is begin - fl_menu_item_set_shortcut (Item.Void_Ptr, Interfaces.C.int (To_C (To))); + fl_menu_item_set_shortcut (This.Void_Ptr, Interfaces.C.int (To_C (To))); end Set_Shortcut; function Get_Flags - (Item : in Menu_Item) + (This : in Menu_Item) return Menu_Flag is begin - return Menu_Flag (fl_menu_item_get_flags (Item.Void_Ptr)); + return Menu_Flag (fl_menu_item_get_flags (This.Void_Ptr)); end Get_Flags; procedure Set_Flags - (Item : in out Menu_Item; + (This : in out Menu_Item; To : in Menu_Flag) is begin - fl_menu_item_set_flags (Item.Void_Ptr, Interfaces.C.unsigned_long (To)); + fl_menu_item_set_flags (This.Void_Ptr, Interfaces.C.unsigned_long (To)); end Set_Flags; + function Get_Image + (This : in Menu_Item) + return access FLTK.Images.Image'Class is + begin + return This.Current_Image; + end Get_Image; + + + procedure Set_Image + (This : in out Menu_Item; + Pict : in out FLTK.Images.Image'Class) is + begin + fl_menu_item_image (This.Void_Ptr, Wrapper (Pict).Void_Ptr); + This.Current_Image := Pict'Unchecked_Access; + end Set_Image; + + + + procedure Activate - (Item : in out Menu_Item) is + (This : in out Menu_Item) is begin - fl_menu_item_activate (Item.Void_Ptr); + fl_menu_item_activate (This.Void_Ptr); end Activate; procedure Deactivate - (Item : in out Menu_Item) is + (This : in out Menu_Item) is begin - fl_menu_item_deactivate (Item.Void_Ptr); + fl_menu_item_deactivate (This.Void_Ptr); end Deactivate; procedure Show - (Item : in out Menu_Item) is + (This : in out Menu_Item) is begin - fl_menu_item_show (Item.Void_Ptr); + fl_menu_item_show (This.Void_Ptr); end Show; procedure Hide - (Item : in out Menu_Item) is + (This : in out Menu_Item) is begin - fl_menu_item_hide (Item.Void_Ptr); + fl_menu_item_hide (This.Void_Ptr); end Hide; function Is_Active - (Item : in Menu_Item) + (This : in Menu_Item) return Boolean is begin - return fl_menu_item_active (Item.Void_Ptr) /= 0; + return fl_menu_item_active (This.Void_Ptr) /= 0; end Is_Active; function Is_Visible - (Item : in Menu_Item) + (This : in Menu_Item) return Boolean is begin - return fl_menu_item_visible (Item.Void_Ptr) /= 0; + return fl_menu_item_visible (This.Void_Ptr) /= 0; end Is_Visible; function Is_Active_And_Visible - (Item : in Menu_Item) + (This : in Menu_Item) return Boolean is begin - return fl_menu_item_activevisible (Item.Void_Ptr) /= 0; + return fl_menu_item_activevisible (This.Void_Ptr) /= 0; end Is_Active_And_Visible; end FLTK.Menu_Items; + diff --git a/src/fltk-menu_items.ads b/src/fltk-menu_items.ads index c2a000c..5c300d3 100644 --- a/src/fltk-menu_items.ads +++ b/src/fltk-menu_items.ads @@ -6,6 +6,7 @@ with + FLTK.Images, FLTK.Widgets; @@ -17,13 +18,15 @@ package FLTK.Menu_Items is type Menu_Item_Reference (Data : not null access Menu_Item'Class) is limited null record with Implicit_Dereference => Data; + type Menu_Item_Array is array (Positive range <>) of Menu_Item; + package Forge is -- Usually you don't bother with this and just add items - -- to Menus directly using the Add subprograms in that package. + -- to Menus directly using the Add/Insert subprograms in that package. function Create (Text : in String; @@ -38,152 +41,176 @@ package FLTK.Menu_Items is function Get_Callback - (Item : in Menu_Item) + (This : in Menu_Item) return FLTK.Widgets.Widget_Callback; procedure Set_Callback - (Item : in out Menu_Item; + (This : in out Menu_Item; Func : in FLTK.Widgets.Widget_Callback); procedure Do_Callback - (Item : in out Menu_Item; + (This : in out Menu_Item; Widget : in out FLTK.Widgets.Widget'Class); function Has_Checkbox - (Item : in Menu_Item) + (This : in Menu_Item) return Boolean; function Is_Radio - (Item : in Menu_Item) + (This : in Menu_Item) + return Boolean; + + function Is_Submenu + (This : in Menu_Item) return Boolean; function Get_State - (Item : in Menu_Item) + (This : in Menu_Item) return Boolean; procedure Set_State - (Item : in out Menu_Item; + (This : in out Menu_Item; To : in Boolean); + procedure Set + (This : in out Menu_Item); + + procedure Clear + (This : in out Menu_Item); + procedure Set_Only - (Item : in out Menu_Item); + (This : in out Menu_Item); function Get_Label - (Item : in Menu_Item) + (This : in Menu_Item) return String; procedure Set_Label - (Item : in out Menu_Item; + (This : in out Menu_Item; + Text : in String); + + procedure Set_Label + (This : in out Menu_Item; + Kind : in Label_Kind; Text : in String); function Get_Label_Color - (Item : in Menu_Item) + (This : in Menu_Item) return Color; procedure Set_Label_Color - (Item : in out Menu_Item; + (This : in out Menu_Item; To : in Color); function Get_Label_Font - (Item : in Menu_Item) + (This : in Menu_Item) return Font_Kind; procedure Set_Label_Font - (Item : in out Menu_Item; + (This : in out Menu_Item; To : in Font_Kind); function Get_Label_Size - (Item : in Menu_Item) + (This : in Menu_Item) return Font_Size; procedure Set_Label_Size - (Item : in out Menu_Item; + (This : in out Menu_Item; To : in Font_Size); function Get_Label_Type - (Item : in Menu_Item) + (This : in Menu_Item) return Label_Kind; procedure Set_Label_Type - (Item : in out Menu_Item; + (This : in out Menu_Item; To : in Label_Kind); function Get_Shortcut - (Item : in Menu_Item) + (This : in Menu_Item) return Key_Combo; procedure Set_Shortcut - (Item : in out Menu_Item; + (This : in out Menu_Item; To : in Key_Combo); function Get_Flags - (Item : in Menu_Item) + (This : in Menu_Item) return Menu_Flag; procedure Set_Flags - (Item : in out Menu_Item; + (This : in out Menu_Item; To : in Menu_Flag); + function Get_Image + (This : in Menu_Item) + return access FLTK.Images.Image'Class; + + procedure Set_Image + (This : in out Menu_Item; + Pict : in out FLTK.Images.Image'Class); + + + + procedure Activate - (Item : in out Menu_Item); + (This : in out Menu_Item); procedure Deactivate - (Item : in out Menu_Item); + (This : in out Menu_Item); procedure Show - (Item : in out Menu_Item); + (This : in out Menu_Item); procedure Hide - (Item : in out Menu_Item); + (This : in out Menu_Item); function Is_Active - (Item : in Menu_Item) + (This : in Menu_Item) return Boolean; function Is_Visible - (Item : in Menu_Item) + (This : in Menu_Item) return Boolean; function Is_Active_And_Visible - (Item : in Menu_Item) + (This : in Menu_Item) return Boolean; private - type Menu_Item is new Wrapper with null record; + type Menu_Item is new Wrapper with record + Current_Image : access FLTK.Images.Image'Class; + end record; overriding procedure Finalize (This : in out Menu_Item); - - pragma Inline (Get_Callback); pragma Inline (Set_Callback); pragma Inline (Do_Callback); - pragma Inline (Has_Checkbox); pragma Inline (Is_Radio); pragma Inline (Get_State); pragma Inline (Set_State); pragma Inline (Set_Only); - pragma Inline (Get_Label); pragma Inline (Set_Label); pragma Inline (Get_Label_Color); @@ -195,12 +222,13 @@ private pragma Inline (Get_Label_Type); pragma Inline (Set_Label_Type); - pragma Inline (Get_Shortcut); pragma Inline (Set_Shortcut); pragma Inline (Get_Flags); pragma Inline (Set_Flags); + pragma Inline (Get_Image); + pragma Inline (Set_Image); pragma Inline (Activate); pragma Inline (Deactivate); @@ -213,3 +241,4 @@ private end FLTK.Menu_Items; + diff --git a/src/fltk-widgets-menus.adb b/src/fltk-widgets-menus.adb index 28653ec..efdeec5 100644 --- a/src/fltk-widgets-menus.adb +++ b/src/fltk-widgets-menus.adb @@ -22,6 +22,9 @@ package body FLTK.Widgets.Menus is package Chk renames Ada.Assertions; + procedure Free_Item is new Ada.Unchecked_Deallocation + (Object => FLTK.Menu_Items.Menu_Item, Name => Item_Access); + @@ -29,6 +32,16 @@ package body FLTK.Widgets.Menus is -- Functions From C -- ------------------------ + function null_fl_menu_item + return Storage.Integer_Address; + pragma Import (C, null_fl_menu_item, "null_fl_menu_item"); + pragma Inline (null_fl_menu_item); + + procedure free_fl_menu_item + (MI : in Storage.Integer_Address); + pragma Import (C, free_fl_menu_item, "free_fl_menu_item"); + pragma Inline (free_fl_menu_item); + function new_fl_menu (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -45,26 +58,62 @@ package body FLTK.Widgets.Menus is function fl_menu_add - (M : in Storage.Integer_Address; - T : in Interfaces.C.char_array; - S : in Interfaces.C.unsigned_long; - C, U : in Storage.Integer_Address; - F : in Interfaces.C.unsigned_long) + (M : in Storage.Integer_Address; + T : in Interfaces.C.char_array) return Interfaces.C.int; pragma Import (C, fl_menu_add, "fl_menu_add"); pragma Inline (fl_menu_add); - function fl_menu_insert + function fl_menu_add2 + (M : in Storage.Integer_Address; + T : in Interfaces.C.char_array; + S : in Interfaces.C.unsigned_long; + U : in Storage.Integer_Address; + F : in Interfaces.C.unsigned_long) + return Interfaces.C.int; + pragma Import (C, fl_menu_add2, "fl_menu_add2"); + pragma Inline (fl_menu_add2); + + function fl_menu_add3 (M : in Storage.Integer_Address; - P : in Interfaces.C.int; - T : in Interfaces.C.char_array; - S : in Interfaces.C.unsigned_long; - C, U : in Storage.Integer_Address; + T, S : in Interfaces.C.char_array; + U : in Storage.Integer_Address; F : in Interfaces.C.unsigned_long) return Interfaces.C.int; + pragma Import (C, fl_menu_add3, "fl_menu_add3"); + pragma Inline (fl_menu_add3); + + function fl_menu_insert + (M : in Storage.Integer_Address; + P : in Interfaces.C.int; + T : in Interfaces.C.char_array; + S : in Interfaces.C.unsigned_long; + U : in Storage.Integer_Address; + F : in Interfaces.C.unsigned_long) + return Interfaces.C.int; pragma Import (C, fl_menu_insert, "fl_menu_insert"); pragma Inline (fl_menu_insert); + function fl_menu_insert2 + (M : in Storage.Integer_Address; + P : in Interfaces.C.int; + T, S : in Interfaces.C.char_array; + U : in Storage.Integer_Address; + F : in Interfaces.C.unsigned_long) + return Interfaces.C.int; + pragma Import (C, fl_menu_insert2, "fl_menu_insert2"); + pragma Inline (fl_menu_insert2); + + procedure fl_menu_copy + (M, I : in Storage.Integer_Address); + pragma Import (C, fl_menu_copy, "fl_menu_copy"); + pragma Inline (fl_menu_copy); + + procedure fl_menu_set_menu + (M, D : in Storage.Integer_Address); + pragma Import (C, fl_menu_set_menu, "fl_menu_set_menu"); + pragma Inline (fl_menu_set_menu); + procedure fl_menu_remove (M : in Storage.Integer_Address; P : in Interfaces.C.int); @@ -76,6 +125,13 @@ package body FLTK.Widgets.Menus is pragma Import (C, fl_menu_clear, "fl_menu_clear"); pragma Inline (fl_menu_clear); + function fl_menu_clear_submenu + (M : in Storage.Integer_Address; + I : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_menu_clear_submenu, "fl_menu_clear_submenu"); + pragma Inline (fl_menu_clear_submenu); + @@ -86,19 +142,6 @@ package body FLTK.Widgets.Menus is pragma Import (C, fl_menu_get_item, "fl_menu_get_item"); pragma Inline (fl_menu_get_item); - function fl_menu_find_item - (M : in Storage.Integer_Address; - T : in Interfaces.C.char_array) - return Storage.Integer_Address; - pragma Import (C, fl_menu_find_item, "fl_menu_find_item"); - pragma Inline (fl_menu_find_item); - - function fl_menu_find_item2 - (M, C : in Storage.Integer_Address) - return Storage.Integer_Address; - pragma Import (C, fl_menu_find_item2, "fl_menu_find_item2"); - pragma Inline (fl_menu_find_item2); - function fl_menu_find_index (M : in Storage.Integer_Address; T : in Interfaces.C.char_array) @@ -116,7 +159,16 @@ package body FLTK.Widgets.Menus is (M, C : in Storage.Integer_Address) return Interfaces.C.int; pragma Import (C, fl_menu_find_index3, "fl_menu_find_index3"); - pragma Inline (fl_menu_find_index3); + -- No inline + + function fl_menu_item_pathname + (M : in Storage.Integer_Address; + B : out Interfaces.C.char_array; + L : in Interfaces.C.int; + I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_menu_item_pathname, "fl_menu_item_pathname"); + pragma Inline (fl_menu_item_pathname); function fl_menu_size (M : in Storage.Integer_Address) @@ -127,12 +179,6 @@ package body FLTK.Widgets.Menus is - function fl_menu_mvalue - (M : in Storage.Integer_Address) - return Storage.Integer_Address; - pragma Import (C, fl_menu_mvalue, "fl_menu_mvalue"); - pragma Inline (fl_menu_mvalue); - function fl_menu_text (M : in Storage.Integer_Address) return Interfaces.C.Strings.chars_ptr; @@ -161,6 +207,49 @@ package body FLTK.Widgets.Menus is + procedure fl_menu_setonly + (M, I : in Storage.Integer_Address); + pragma Import (C, fl_menu_setonly, "fl_menu_setonly"); + pragma Inline (fl_menu_setonly); + + function fl_menu_text2 + (M : in Storage.Integer_Address; + I : in Interfaces.C.int) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_menu_text2, "fl_menu_text2"); + pragma Inline (fl_menu_text2); + + procedure fl_menu_replace + (M : in Storage.Integer_Address; + I : in Interfaces.C.int; + T : in Interfaces.C.char_array); + pragma Import (C, fl_menu_replace, "fl_menu_replace"); + pragma Inline (fl_menu_replace); + + procedure fl_menu_shortcut + (M : in Storage.Integer_Address; + I : in Interfaces.C.int; + S : in Interfaces.C.unsigned_long); + pragma Import (C, fl_menu_shortcut, "fl_menu_shortcut"); + pragma Inline (fl_menu_shortcut); + + function fl_menu_get_mode + (M : in Storage.Integer_Address; + I : in Interfaces.C.int) + return Interfaces.C.unsigned_long; + pragma Import (C, fl_menu_get_mode, "fl_menu_get_mode"); + pragma Inline (fl_menu_get_mode); + + procedure fl_menu_set_mode + (M : in Storage.Integer_Address; + I : in Interfaces.C.int; + F : in Interfaces.C.unsigned_long); + pragma Import (C, fl_menu_set_mode, "fl_menu_set_mode"); + pragma Inline (fl_menu_set_mode); + + + + function fl_menu_get_textcolor (M : in Storage.Integer_Address) return Interfaces.C.unsigned; @@ -231,11 +320,11 @@ package body FLTK.Widgets.Menus is function fl_menu_popup (M : in Storage.Integer_Address; X, Y : in Interfaces.C.int; - T : in Interfaces.C.char_array; + T : in Interfaces.C.Strings.chars_ptr; N : in Interfaces.C.int) return Storage.Integer_Address; pragma Import (C, fl_menu_popup, "fl_menu_popup"); - pragma Inline (fl_menu_popup); + -- No inline function fl_menu_pulldown (M : in Storage.Integer_Address; @@ -243,7 +332,35 @@ package body FLTK.Widgets.Menus is N : in Interfaces.C.int) return Storage.Integer_Address; pragma Import (C, fl_menu_pulldown, "fl_menu_pulldown"); - pragma Inline (fl_menu_pulldown); + -- No inline + + function fl_menu_picked + (M, I : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_menu_picked, "fl_menu_picked"); + pragma Inline (fl_menu_picked); + + function fl_menu_find_shortcut + (M, I : in Storage.Integer_Address; + A : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, fl_menu_find_shortcut, "fl_menu_find_shortcut"); + pragma Inline (fl_menu_find_shortcut); + + function fl_menu_test_shortcut + (M : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_menu_test_shortcut, "fl_menu_test_shortcut"); + pragma Inline (fl_menu_test_shortcut); + + + + + procedure fl_menu_size2 + (M : in Storage.Integer_Address; + W, H : in Interfaces.C.int); + pragma Import (C, fl_menu_size2, "fl_menu_size2"); + pragma Inline (fl_menu_size2); @@ -271,22 +388,54 @@ package body FLTK.Widgets.Menus is + ------------------------ + -- Internal Utility -- + ------------------------ + + procedure Adjust_Item_Store + (This : in out Menu) + is + Target : Natural := This.Number_Of_Items; + begin + while Natural (This.My_Items.Length) > Target loop + Free_Item (This.My_Items.Reference (This.My_Items.Last_Index)); + This.My_Items.Delete_Last; + end loop; + while Natural (This.My_Items.Length) < Target loop + This.My_Items.Append (new FLTK.Menu_Items.Menu_Item); + Wrapper (This.My_Items.Last_Element.all).Needs_Dealloc := False; + end loop; + end Adjust_Item_Store; + + + -- Needed for setting a whole array of Menu_Items at once + Null_Item : Storage.Integer_Address := null_fl_menu_item; + + + + ---------------------- -- Callback Hooks -- ---------------------- procedure Item_Hook - (M, U : in Storage.Integer_Address) + (C_Obj, User_Data : in Storage.Integer_Address); + pragma Export (C, Item_Hook, "menu_item_callback_hook"); + + -- Used for Add and Insert, the userdata parameter is the actual callback we want + procedure Item_Hook + (C_Obj, User_Data : in Storage.Integer_Address) is - C_Ptr : Storage.Integer_Address := fl_widget_get_user_data (M); + Ada_Ptr : Storage.Integer_Address := fl_widget_get_user_data (C_Obj); Ada_Widget : access Widget'Class; - Action : Widget_Callback := Callback_Convert.To_Access (U); + Action : Widget_Callback := Callback_Convert.To_Access (User_Data); begin - pragma Assert (C_Ptr /= Null_Pointer); - Ada_Widget := Widget_Convert.To_Pointer (Storage.To_Address (C_Ptr)); + pragma Assert (Ada_Ptr /= Null_Pointer); + Ada_Widget := Widget_Convert.To_Pointer (Storage.To_Address (Ada_Ptr)); Action.all (Ada_Widget.all); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Callback in Fl_Menu_ was supplied Widget pointer with no user data"; end Item_Hook; @@ -296,10 +445,6 @@ package body FLTK.Widgets.Menus is -- Destructors -- ------------------- - procedure Free_Item is new Ada.Unchecked_Deallocation - (Object => FLTK.Menu_Items.Menu_Item, Name => Item_Access); - - procedure Extra_Final (This : in out Menu) is begin @@ -321,6 +466,16 @@ package body FLTK.Widgets.Menus is end Finalize; + procedure Finalize + (This : in out Menu_Final_Controller) is + begin + if Null_Item /= Null_Pointer then + free_fl_menu_item (Null_Item); + Null_Item := Null_Pointer; + end if; + end Finalize; + + -------------------- @@ -339,8 +494,10 @@ package body FLTK.Widgets.Menus is procedure Initialize (This : in out Menu) is begin - This.Draw_Ptr := fl_menu_draw'Address; + This.Draw_Ptr := fl_menu_draw'Address; This.Handle_Ptr := fl_menu_handle'Address; + Wrapper (This.My_Find).Needs_Dealloc := False; + Wrapper (This.My_Pick).Needs_Dealloc := False; end Initialize; @@ -353,11 +510,11 @@ package body FLTK.Widgets.Menus is begin return This : Menu do This.Void_Ptr := new_fl_menu - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -372,32 +529,100 @@ package body FLTK.Widgets.Menus is ----------------------- procedure Add + (This : in out Menu; + Text : in String) + is + Added_Spot : Interfaces.C.int := fl_menu_add (This.Void_Ptr, Interfaces.C.To_C (Text)); + begin + This.Adjust_Item_Store; + end Add; + + + function Add + (This : in out Menu; + Text : in String) + return Index + is + Added_Spot : Interfaces.C.int := fl_menu_add (This.Void_Ptr, Interfaces.C.To_C (Text)); + begin + This.Adjust_Item_Store; + return Index (Added_Spot + 1); + end Add; + + + procedure Add (This : in out Menu; Text : in String; Action : in Widget_Callback := null; Shortcut : in Key_Combo := No_Key; Flags : in Menu_Flag := Flag_Normal) is - Ret_Place : Interfaces.C.int; - Callback, User_Data : Storage.Integer_Address := Null_Pointer; + Added_Spot : Interfaces.C.int := fl_menu_add2 + (This.Void_Ptr, + Interfaces.C.To_C (Text), + To_C (Shortcut), + Callback_Convert.To_Address (Action), + Interfaces.C.unsigned_long (Flags)); begin - if Action /= null then - Callback := Storage.To_Integer (Item_Hook'Address); - User_Data := Callback_Convert.To_Address (Action); - end if; - Ret_Place := fl_menu_add + This.Adjust_Item_Store; + end Add; + + + function Add + (This : in out Menu; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in Key_Combo := No_Key; + Flags : in Menu_Flag := Flag_Normal) + return Index + is + Added_Spot : Interfaces.C.int := fl_menu_add2 (This.Void_Ptr, Interfaces.C.To_C (Text), To_C (Shortcut), - Callback, - User_Data, + Callback_Convert.To_Address (Action), Interfaces.C.unsigned_long (Flags)); - This.My_Items.Append (new FLTK.Menu_Items.Menu_Item); - Wrapper (This.My_Items.Last_Element.all).Needs_Dealloc := False; - if Flags + Flag_Submenu = Flags then - This.My_Items.Append (new FLTK.Menu_Items.Menu_Item); - Wrapper (This.My_Items.Last_Element.all).Needs_Dealloc := False; - end if; + begin + This.Adjust_Item_Store; + return Index (Added_Spot + 1); + end Add; + + + procedure Add + (This : in out Menu; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in String; + Flags : in Menu_Flag := Flag_Normal) + is + Added_Spot : Interfaces.C.int := fl_menu_add3 + (This.Void_Ptr, + Interfaces.C.To_C (Text), + Interfaces.C.To_C (Shortcut), + Callback_Convert.To_Address (Action), + Interfaces.C.unsigned_long (Flags)); + begin + This.Adjust_Item_Store; + end Add; + + + function Add + (This : in out Menu; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in String; + Flags : in Menu_Flag := Flag_Normal) + return Index + is + Added_Spot : Interfaces.C.int := fl_menu_add3 + (This.Void_Ptr, + Interfaces.C.To_C (Text), + Interfaces.C.To_C (Shortcut), + Callback_Convert.To_Address (Action), + Interfaces.C.unsigned_long (Flags)); + begin + This.Adjust_Item_Store; + return Index (Added_Spot + 1); end Add; @@ -409,37 +634,112 @@ package body FLTK.Widgets.Menus is Shortcut : in Key_Combo := No_Key; Flags : in Menu_Flag := Flag_Normal) is - Ret_Place : Interfaces.C.int; - Callback, User_Data : Storage.Integer_Address := Null_Pointer; + Added_Spot : Interfaces.C.int := fl_menu_insert + (This.Void_Ptr, + Interfaces.C.int (Place) - 1, + Interfaces.C.To_C (Text), + To_C (Shortcut), + Callback_Convert.To_Address (Action), + Interfaces.C.unsigned_long (Flags)); begin - if Action /= null then - Callback := Storage.To_Integer (Item_Hook'Address); - User_Data := Callback_Convert.To_Address (Action); - end if; - Ret_Place := fl_menu_insert + This.Adjust_Item_Store; + end Insert; + + + function Insert + (This : in out Menu; + Place : in Index; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in Key_Combo := No_Key; + Flags : in Menu_Flag := Flag_Normal) + return Index + is + Added_Spot : Interfaces.C.int := fl_menu_insert (This.Void_Ptr, Interfaces.C.int (Place) - 1, Interfaces.C.To_C (Text), To_C (Shortcut), - Callback, - User_Data, + Callback_Convert.To_Address (Action), Interfaces.C.unsigned_long (Flags)); - This.My_Items.Append (new FLTK.Menu_Items.Menu_Item); - Wrapper (This.My_Items.Last_Element.all).Needs_Dealloc := False; - if Flags + Flag_Submenu = Flags then - This.My_Items.Append (new FLTK.Menu_Items.Menu_Item); - Wrapper (This.My_Items.Last_Element.all).Needs_Dealloc := False; - end if; + begin + This.Adjust_Item_Store; + return Index (Added_Spot + 1); + end Insert; + + + procedure Insert + (This : in out Menu; + Place : in Index; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in String; + Flags : in Menu_Flag := Flag_Normal) + is + Added_Spot : Interfaces.C.int := fl_menu_insert2 + (This.Void_Ptr, + Interfaces.C.int (Place) - 1, + Interfaces.C.To_C (Text), + Interfaces.C.To_C (Shortcut), + Callback_Convert.To_Address (Action), + Interfaces.C.unsigned_long (Flags)); + begin + This.Adjust_Item_Store; end Insert; + function Insert + (This : in out Menu; + Place : in Index; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in String; + Flags : in Menu_Flag := Flag_Normal) + return Index + is + Added_Spot : Interfaces.C.int := fl_menu_insert2 + (This.Void_Ptr, + Interfaces.C.int (Place) - 1, + Interfaces.C.To_C (Text), + Interfaces.C.To_C (Shortcut), + Callback_Convert.To_Address (Action), + Interfaces.C.unsigned_long (Flags)); + begin + This.Adjust_Item_Store; + return Index (Added_Spot + 1); + end Insert; + + + procedure Set_Items + (This : in out Menu; + Items : in FLTK.Menu_Items.Menu_Item_Array) + is + Pointers : aliased array (Items'First .. Items'Last + 1) of Storage.Integer_Address; + pragma Convention (C, Pointers); + begin + for Place in Pointers'First .. Pointers'Last - 1 loop + Pointers (Place) := Wrapper (Items (Place)).Void_Ptr; + end loop; + Pointers (Pointers'Last) := Null_Item; + fl_menu_copy (This.Void_Ptr, Storage.To_Integer (Pointers (Pointers'First)'Address)); + end Set_Items; + + + procedure Use_Same_Items + (This : in out Menu; + Donor : in Menu'Class) is + begin + -- Donor menu() pointer will be obtained in C++ + fl_menu_set_menu (This.Void_Ptr, Donor.Void_Ptr); + end Use_Same_Items; + + procedure Remove (This : in out Menu; Place : in Index) is begin - Free_Item (This.My_Items.Reference (Place)); - This.My_Items.Delete (Place); fl_menu_remove (This.Void_Ptr, Interfaces.C.int (Place) - 1); + This.Adjust_Item_Store; end Remove; @@ -454,6 +754,27 @@ package body FLTK.Widgets.Menus is end Clear; + procedure Clear_Submenu + (This : in out Menu; + Place : in Index) + is + Result : Interfaces.C.int := fl_menu_clear_submenu + (This.Void_Ptr, + Interfaces.C.int (Place) - 1); + begin + if Result = -1 then + raise No_Reference_Error; + else + pragma Assert (Result = 0); + This.Adjust_Item_Store; + end if; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Call to Fl_Menu_::clear_submenu returned unexpected int result of " & + Interfaces.C.int'Image (Result); + end Clear_Submenu; + + function Has_Item @@ -480,9 +801,7 @@ package body FLTK.Widgets.Menus is begin Wrapper (This.My_Items (Place).all).Void_Ptr := fl_menu_get_item (This.Void_Ptr, Interfaces.C.int (Place) - 1); - return R : FLTK.Menu_Items.Menu_Item_Reference := (Data => This.My_Items (Place)) do - null; - end return; + return (Data => This.My_Items (Place).all'Unchecked_Access); end Item; @@ -503,13 +822,9 @@ package body FLTK.Widgets.Menus is Place : Extended_Index := This.Find_Index (Name); begin if Place = No_Index then - raise No_Reference; + raise No_Reference_Error; end if; - Wrapper (This.My_Items (Place).all).Void_Ptr := - fl_menu_find_item (This.Void_Ptr, Interfaces.C.To_C (Name)); - return R : FLTK.Menu_Items.Menu_Item_Reference := (Data => This.My_Items (Place)) do - null; - end return; + return This.Item (Place); end Find_Item; @@ -521,13 +836,9 @@ package body FLTK.Widgets.Menus is Place : Extended_Index := This.Find_Index (Action); begin if Place = No_Index then - raise No_Reference; + raise No_Reference_Error; end if; - Wrapper (This.My_Items (Place).all).Void_Ptr := fl_menu_find_item2 - (This.Void_Ptr, Callback_Convert.To_Address (Action)); - return R : FLTK.Menu_Items.Menu_Item_Reference := (Data => This.My_Items (Place)) do - null; - end return; + return This.Item (Place); end Find_Item; @@ -536,10 +847,9 @@ package body FLTK.Widgets.Menus is Name : in String) return Extended_Index is - Ret : Interfaces.C.int; + Result : Interfaces.C.int := fl_menu_find_index (This.Void_Ptr, Interfaces.C.To_C (Name)); begin - Ret := fl_menu_find_index (This.Void_Ptr, Interfaces.C.To_C (Name)); - return Extended_Index (Ret + 1); + return Extended_Index (Result + 1); end Find_Index; @@ -548,10 +858,9 @@ package body FLTK.Widgets.Menus is Item : in FLTK.Menu_Items.Menu_Item) return Extended_Index is - Ret : Interfaces.C.int; + Result : Interfaces.C.int := fl_menu_find_index2 (This.Void_Ptr, Wrapper (Item).Void_Ptr); begin - Ret := fl_menu_find_index2 (This.Void_Ptr, Wrapper (Item).Void_Ptr); - return Extended_Index (Ret + 1); + return Extended_Index (Result + 1); end Find_Index; @@ -560,20 +869,78 @@ package body FLTK.Widgets.Menus is Action : in Widget_Callback) return Extended_Index is - Ret : Interfaces.C.int; + Result : Interfaces.C.int; begin - Ret := fl_menu_find_index3 - (This.Void_Ptr, - Callback_Convert.To_Address (Action)); - return Extended_Index (Ret + 1); + -- Don't worry, callbacks actually being stored in userdata is + -- taken into account on the C++ side. + Result := fl_menu_find_index3 (This.Void_Ptr, Callback_Convert.To_Address (Action)); + return Extended_Index (Result + 1); end Find_Index; + function Item_Pathname + (This : in Menu) + return String + is + Buffer : Interfaces.C.char_array := + (0 .. Interfaces.C.size_t (Item_Path_Max) => Interfaces.C.nul); + Result : Interfaces.C.int := fl_menu_item_pathname + (This.Void_Ptr, + Buffer, + Interfaces.C.int (Item_Path_Max), + Null_Pointer); + begin + case Result is + when -1 => raise No_Reference_Error; + when -2 => raise Internal_FLTK_Error with "Item_Pathname buffer of " & + Integer'Image (Item_Path_Max) & " was not long enough"; + when others => + pragma Assert (Result = 0); + return Interfaces.C.To_Ada (Buffer); + end case; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Call to Fl_Menu_::item_pathname returned unexpected int result of " & + Interfaces.C.int'Image (Result); + end Item_Pathname; + + + function Item_Pathname + (This : in Menu; + Item : in FLTK.Menu_Items.Menu_Item) + return String + is + Buffer : Interfaces.C.char_array := + (0 .. Interfaces.C.size_t (Item_Path_Max) => Interfaces.C.nul); + Result : Interfaces.C.int := fl_menu_item_pathname + (This.Void_Ptr, + Buffer, + Interfaces.C.int (Item_Path_Max), + Wrapper (Item).Void_Ptr); + begin + case Result is + when -1 => raise No_Reference_Error; + when -2 => raise Internal_FLTK_Error with "Item_Pathname buffer of " & + Integer'Image (Item_Path_Max) & " was not long enough"; + when others => + pragma Assert (Result = 0); + return Interfaces.C.To_Ada (Buffer); + end case; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Call to Fl_Menu_::item_pathname returned unexpected int result of " & + Interfaces.C.int'Image (Result); + end Item_Pathname; + + function Number_Of_Items (This : in Menu) return Natural is begin return Natural (fl_menu_size (This.Void_Ptr)); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Call to Fl_Menu_::size returned unexpected negative result"; end Number_Of_Items; @@ -638,12 +1005,9 @@ package body FLTK.Widgets.Menus is Place : Extended_Index := This.Chosen_Index; begin if Place = No_Index then - raise No_Reference; + raise No_Reference_Error; end if; - Wrapper (This.My_Items (Place).all).Void_Ptr := fl_menu_mvalue (This.Void_Ptr); - return R : FLTK.Menu_Items.Menu_Item_Reference := (Data => This.My_Items (Place)) do - null; - end return; + return This.Item (Place); end Chosen; @@ -656,7 +1020,6 @@ package body FLTK.Widgets.Menus is if Ptr = Interfaces.C.Strings.Null_Ptr then return ""; else - -- no dealloc required? return Interfaces.C.Strings.Value (Ptr); end if; end Chosen_Label; @@ -674,9 +1037,18 @@ package body FLTK.Widgets.Menus is (This : in out Menu; Place : in Index) is - Ignore_Ret : Interfaces.C.int; + Ignore : Interfaces.C.int; begin - Ignore_Ret := fl_menu_set_value (This.Void_Ptr, Interfaces.C.int (Place) - 1); + Ignore := fl_menu_set_value (This.Void_Ptr, Interfaces.C.int (Place) - 1); + end Set_Chosen; + + + function Set_Chosen + (This : in out Menu; + Place : in Index) + return Boolean is + begin + return fl_menu_set_value (This.Void_Ptr, Interfaces.C.int (Place) - 1) /= 0; end Set_Chosen; @@ -684,14 +1056,95 @@ package body FLTK.Widgets.Menus is (This : in out Menu; Item : in FLTK.Menu_Items.Menu_Item) is - Ignore_Ret : Interfaces.C.int; + Ignore : Interfaces.C.int; + begin + Ignore := fl_menu_set_value2 (This.Void_Ptr, Wrapper (Item).Void_Ptr); + end Set_Chosen; + + + function Set_Chosen + (This : in out Menu; + Item : in FLTK.Menu_Items.Menu_Item) + return Boolean is begin - Ignore_Ret := fl_menu_set_value2 (This.Void_Ptr, Wrapper (Item).Void_Ptr); + return fl_menu_set_value2 (This.Void_Ptr, Wrapper (Item).Void_Ptr) /= 0; end Set_Chosen; + procedure Set_Only + (This : in out Menu; + Item : in out FLTK.Menu_Items.Menu_Item) is + begin + fl_menu_setonly (This.Void_Ptr, Wrapper (Item).Void_Ptr); + end Set_Only; + + + function Get_Label + (This : in Menu; + Place : in Index) + return String + is + Result : Interfaces.C.Strings.chars_ptr := fl_menu_text2 + (This.Void_Ptr, + Interfaces.C.int (Place) - 1); + begin + if Result = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Result); + end if; + end Get_Label; + + + procedure Set_Label + (This : in out Menu; + Place : in Index; + Text : in String) is + begin + fl_menu_replace + (This.Void_Ptr, + Interfaces.C.int (Place) - 1, + Interfaces.C.To_C (Text)); + end Set_Label; + + + procedure Set_Shortcut + (This : in out Menu; + Place : in Index; + Press : in Key_Combo) is + begin + fl_menu_shortcut + (This.Void_Ptr, + Interfaces.C.int (Place) - 1, + To_C (Press)); + end Set_Shortcut; + + + function Get_Flags + (This : in Menu; + Place : in Index) + return Menu_Flag is + begin + return Menu_Flag (fl_menu_get_mode (This.Void_Ptr, Interfaces.C.int (Place) - 1)); + end Get_Flags; + + + procedure Set_Flags + (This : in out Menu; + Place : in Index; + Flags : in Menu_Flag) is + begin + fl_menu_set_mode + (This.Void_Ptr, + Interfaces.C.int (Place) - 1, + Interfaces.C.unsigned_long (Flags)); + end Set_Flags; + + + + function Get_Text_Color (This : in Menu) return Color is @@ -710,9 +1163,15 @@ package body FLTK.Widgets.Menus is function Get_Text_Font (This : in Menu) - return Font_Kind is + return Font_Kind + is + Result : Interfaces.C.int := fl_menu_get_textfont (This.Void_Ptr); begin - return Font_Kind'Val (fl_menu_get_textfont (This.Void_Ptr)); + return Font_Kind'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Menu_::textfont returned unexpected Font value of " & + Interfaces.C.int'Image (Result); end Get_Text_Font; @@ -726,9 +1185,15 @@ package body FLTK.Widgets.Menus is function Get_Text_Size (This : in Menu) - return Font_Size is + return Font_Size + is + Result : Interfaces.C.int := fl_menu_get_textsize (This.Void_Ptr); begin - return Font_Size (fl_menu_get_textsize (This.Void_Ptr)); + return Font_Size (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Menu_::textsize returned unexpected Size value of " & + Interfaces.C.int'Image (Result); end Get_Text_Size; @@ -744,9 +1209,15 @@ package body FLTK.Widgets.Menus is function Get_Down_Box (This : in Menu) - return Box_Kind is + return Box_Kind + is + Result : Interfaces.C.int := fl_menu_get_down_box (This.Void_Ptr); begin - return Box_Kind'Val (fl_menu_get_down_box (This.Void_Ptr)); + return Box_Kind'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Menu_::down_box returned unexpected Box value of " & + Interfaces.C.int'Image (Result); end Get_Down_Box; @@ -786,11 +1257,14 @@ package body FLTK.Widgets.Menus is Initial : in Extended_Index := No_Index) return Extended_Index is + C_Title : aliased Interfaces.C.char_array := Interfaces.C.To_C (Title); Ptr : Storage.Integer_Address := fl_menu_popup (This.Void_Ptr, Interfaces.C.int (X), Interfaces.C.int (Y), - Interfaces.C.To_C (Title), + (if Title = "" + then Interfaces.C.Strings.Null_Ptr + else Interfaces.C.Strings.To_Chars_Ptr (C_Title'Unchecked_Access)), Interfaces.C.int (Initial) - 1); begin return Extended_Index (fl_menu_find_index2 (This.Void_Ptr, Ptr) + 1); @@ -815,6 +1289,88 @@ package body FLTK.Widgets.Menus is end Pulldown; + procedure Picked + (This : in out Menu; + Item : in out FLTK.Menu_Items.Menu_Item) + is + Ignore : Storage.Integer_Address := fl_menu_picked + (This.Void_Ptr, + Wrapper (Item).Void_Ptr); + begin + null; + end Picked; + + + function Find_Shortcut + (This : in out Menu; + Require_Alt : in Boolean := False) + return access FLTK.Menu_Items.Menu_Item'Class + is + Tentative_Result : Storage.Integer_Address := fl_menu_find_shortcut + (This.Void_Ptr, + Null_Pointer, + Boolean'Pos (Require_Alt)); + begin + if Tentative_Result = Null_Pointer then + return null; + else + Wrapper (This.My_Find).Void_Ptr := Tentative_Result; + return This.My_Find'Unchecked_Access; + end if; + end Find_Shortcut; + + + function Find_Shortcut + (This : in out Menu; + Place : out Extended_Index; + Require_Alt : in Boolean := False) + return access FLTK.Menu_Items.Menu_Item'Class + is + C_Place : Interfaces.C.int; + Tentative_Result : Storage.Integer_Address := fl_menu_find_shortcut + (This.Void_Ptr, + Storage.To_Integer (C_Place'Address), + Boolean'Pos (Require_Alt)); + begin + if Tentative_Result = Null_Pointer then + Place := No_Index; + return null; + else + Wrapper (This.My_Find).Void_Ptr := Tentative_Result; + Place := Index (C_Place + 1); + return This.My_Find'Unchecked_Access; + end if; + end Find_Shortcut; + + + function Test_Shortcut + (This : in out Menu) + return access FLTK.Menu_Items.Menu_Item'Class + is + Tentative_Pick : Storage.Integer_Address := fl_menu_test_shortcut (This.Void_Ptr); + begin + if Tentative_Pick = Null_Pointer then + return null; + else + Wrapper (This.My_Pick).Void_Ptr := Tentative_Pick; + return This.My_Pick'Unchecked_Access; + end if; + end Test_Shortcut; + + + + + procedure Resize + (This : in out Menu; + W, H : in Integer) is + begin + fl_menu_size2 + (This.Void_Ptr, + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Resize; + + procedure Draw_Item diff --git a/src/fltk-widgets-menus.ads b/src/fltk-widgets-menus.ads index 1d7b55b..5285414 100644 --- a/src/fltk-widgets-menus.ads +++ b/src/fltk-widgets-menus.ads @@ -12,6 +12,7 @@ with private with Ada.Containers.Vectors, + Ada.Finalization, Interfaces; @@ -30,11 +31,18 @@ package FLTK.Widgets.Menus is subtype Extended_Index is Natural; No_Index : constant Extended_Index := Extended_Index'First; - No_Reference : exception; type Cursor is private; + -- If your menu item path names are longer than this, + -- then calls to Item_Pathname will raise an exception. + Item_Path_Max : constant Integer := 1023; + + + No_Reference_Error : exception; + + package Forge is @@ -50,12 +58,44 @@ package FLTK.Widgets.Menus is procedure Add + (This : in out Menu; + Text : in String); + + function Add + (This : in out Menu; + Text : in String) + return Index; + + procedure Add (This : in out Menu; Text : in String; Action : in Widget_Callback := null; Shortcut : in Key_Combo := No_Key; Flags : in Menu_Flag := Flag_Normal); + function Add + (This : in out Menu; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in Key_Combo := No_Key; + Flags : in Menu_Flag := Flag_Normal) + return Index; + + procedure Add + (This : in out Menu; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in String; + Flags : in Menu_Flag := Flag_Normal); + + function Add + (This : in out Menu; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in String; + Flags : in Menu_Flag := Flag_Normal) + return Index; + procedure Insert (This : in out Menu; Place : in Index; @@ -64,6 +104,40 @@ package FLTK.Widgets.Menus is Shortcut : in Key_Combo := No_Key; Flags : in Menu_Flag := Flag_Normal); + function Insert + (This : in out Menu; + Place : in Index; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in Key_Combo := No_Key; + Flags : in Menu_Flag := Flag_Normal) + return Index; + + procedure Insert + (This : in out Menu; + Place : in Index; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in String; + Flags : in Menu_Flag := Flag_Normal); + + function Insert + (This : in out Menu; + Place : in Index; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in String; + Flags : in Menu_Flag := Flag_Normal) + return Index; + + procedure Set_Items + (This : in out Menu; + Items : in FLTK.Menu_Items.Menu_Item_Array); + + procedure Use_Same_Items + (This : in out Menu; + Donor : in Menu'Class); + procedure Remove (This : in out Menu; Place : in Index); @@ -71,6 +145,10 @@ package FLTK.Widgets.Menus is procedure Clear (This : in out Menu); + procedure Clear_Submenu + (This : in out Menu; + Place : in Index); + @@ -118,6 +196,16 @@ package FLTK.Widgets.Menus is Action : in Widget_Callback) return Extended_Index; + function Item_Pathname + (This : in Menu) + return String; + + function Item_Pathname + (This : in Menu; + Item : in FLTK.Menu_Items.Menu_Item) + return String; + + -- May not be what you expect due to submenu terminators function Number_Of_Items (This : in Menu) return Natural; @@ -151,10 +239,52 @@ package FLTK.Widgets.Menus is (This : in out Menu; Place : in Index); + function Set_Chosen + (This : in out Menu; + Place : in Index) + return Boolean; + procedure Set_Chosen (This : in out Menu; Item : in FLTK.Menu_Items.Menu_Item); + function Set_Chosen + (This : in out Menu; + Item : in FLTK.Menu_Items.Menu_Item) + return Boolean; + + + + + procedure Set_Only + (This : in out Menu; + Item : in out FLTK.Menu_Items.Menu_Item); + + function Get_Label + (This : in Menu; + Place : in Index) + return String; + + procedure Set_Label + (This : in out Menu; + Place : in Index; + Text : in String); + + procedure Set_Shortcut + (This : in out Menu; + Place : in Index; + Press : in Key_Combo); + + function Get_Flags + (This : in Menu; + Place : in Index) + return Menu_Flag; + + procedure Set_Flags + (This : in out Menu; + Place : in Index; + Flags : in Menu_Flag); + @@ -217,6 +347,32 @@ package FLTK.Widgets.Menus is Initial : in Extended_Index := No_Index) return Extended_Index; + procedure Picked + (This : in out Menu; + Item : in out FLTK.Menu_Items.Menu_Item); + + function Find_Shortcut + (This : in out Menu; + Require_Alt : in Boolean := False) + return access FLTK.Menu_Items.Menu_Item'Class; + + function Find_Shortcut + (This : in out Menu; + Place : out Extended_Index; + Require_Alt : in Boolean := False) + return access FLTK.Menu_Items.Menu_Item'Class; + + function Test_Shortcut + (This : in out Menu) + return access FLTK.Menu_Items.Menu_Item'Class; + + + + + procedure Resize + (This : in out Menu; + W, H : in Integer); + @@ -238,11 +394,13 @@ private type Item_Access is access FLTK.Menu_Items.Menu_Item; package Item_Vectors is new Ada.Containers.Vectors - (Index_Type => Positive, + (Index_Type => Positive, Element_Type => Item_Access); type Menu is new Widget with record My_Items : Item_Vectors.Vector; + My_Find : aliased FLTK.Menu_Items.Menu_Item; + My_Pick : aliased FLTK.Menu_Items.Menu_Item; end record; overriding procedure Initialize @@ -261,10 +419,6 @@ private (This : in out Menu); - procedure Item_Hook (M, U : in Storage.Integer_Address); - pragma Convention (C, Item_Hook); - - type Cursor is record My_Container : access Menu; My_Index : Index'Base := Index'First; @@ -293,6 +447,8 @@ private return Cursor; + pragma Inline (Use_Same_Items); + pragma Inline (Has_Item); pragma Inline (Item); pragma Inline (Find_Item); @@ -306,6 +462,13 @@ private pragma Inline (Chosen_Index); pragma Inline (Set_Chosen); + pragma Inline (Set_Only); + pragma Inline (Get_Label); + pragma Inline (Set_Label); + pragma Inline (Set_Shortcut); + pragma Inline (Get_Flags); + pragma Inline (Set_Flags); + pragma Inline (Get_Text_Color); pragma Inline (Set_Text_Color); pragma Inline (Get_Text_Font); @@ -320,10 +483,22 @@ private pragma Inline (Popup); pragma Inline (Pulldown); + pragma Inline (Picked); + pragma Inline (Test_Shortcut); + + pragma Inline (Resize); pragma Inline (Draw_Item); + type Menu_Final_Controller is new Ada.Finalization.Limited_Controlled with null record; + + overriding procedure Finalize + (This : in out Menu_Final_Controller); + + Cleanup : Menu_Final_Controller; + + end FLTK.Widgets.Menus; |