Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100755 789 lines (646 sloc) 28.3 kB
4b0de46 Committer: James Tappin <james@amarice.(none)>
James Tappin authored
1 ! Copyright (C) 2011
2 ! Free Software Foundation, Inc.
3
4 ! This file is part of the gtk-fortran GTK+ Fortran Interface library.
5
6 ! This is free software; you can redistribute it and/or modify
7 ! it under the terms of the GNU General Public License as published by
8 ! the Free Software Foundation; either version 3, or (at your option)
9 ! any later version.
10
11 ! This software is distributed in the hope that it will be useful,
12 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ! GNU General Public License for more details.
15
16 ! Under Section 7 of GPL version 3, you are granted additional
17 ! permissions described in the GCC Runtime Library Exception, version
18 ! 3.1, as published by the Free Software Foundation.
19
20 ! You should have received a copy of the GNU General Public License along with
21 ! this program; see the files COPYING3 and COPYING.RUNTIME respectively.
22 ! If not, see <http://www.gnu.org/licenses/>.
23 !
24 ! Contributed by James Tappin
25 ! Last modification: 03-30-2011
26
27 module gtk_hl
28 ! A bunch of procedures to implement higher level creators for
29 ! the gtk-fortran widgets. Some settings and operations are also
30 ! provided for the more intricate widgets.
31 !
32 ! To date this is very incomplete.
33 !
34 ! Many ideas in this module were taken from the pilib gtk<->fortran
35 ! interface.
36
37 ! Currently included:
38 ! hl_gtk_window_new: A top-level window.
39 ! hl_gtk_button_new: A simple button
40 ! hl_gtk_check_button_new: A check button
41 ! hl_gtk_radio_button_new: A radio button with group.
42 ! hl_gtk_radio_group_get_select: Which member of a radio group
43 ! is selected.
44 ! hl_gtk_radio_group_set_select: Select a member of a radio group.
45 ! hl_gtk_entry_new: A 1-line text box
46 ! hl_gtk_list1_new: A single column list with indexing
47 ! hl_gtk_list1_get_selections: Get the selected row(s) from a list.
48 ! hl_gtk_list1_ins: Insert a row into a list
49 ! hl_gtk_list1_rem: Delete a row from a list, or clear the list.
50 ! hl_gtk_menu_new: Create a menubar.
51 ! hl_gtk_menu_submenu: Add a submenu to a menu
52 ! hl_gtk_menu_item: Add a button to a menu
53 ! hl_gtk_progress_bar_new: A progress bar.
54 ! hl_gtk_progress_bar_set: Set the value of a progress bar.
55
56 ! The iso_c_binding & gtk modules are implicitly included in the
57 ! gtk_sup -- speeds compilation to omit them here.
58 ! use iso_c_binding
59 ! use gtk
60 use gtk_sup
61
62 implicit none
63
64 interface hl_gtk_progress_bar_set
65 module procedure hl_gtk_progress_bar_set_f
66 module procedure hl_gtk_progress_bar_set_ii
67 end interface hl_gtk_progress_bar_set
68
69 contains
70
71 function hl_gtk_window_new(title, destroy, delete_event, border, wsize,&
72 & sensitive) result(win)
73 ! Higher-level interface to make a gtk_window
74 !
75 ! TITLE: String: optional: Title for the window
76 ! DESTROY: c_funptr: optional: Callback for the "destroy" signal
77 ! DELETE_EVENT: c_funptr: optional: Callback for the "delete-event" signal
78 ! BORDER: integer: optional: Size of the window border
79 ! WSIZE: integer(2): optional: Size of the window
80 ! SENSITIVE: logical: optional: Whether the widget should initially
81 ! be sensitive or not.
82
83 type(c_ptr) :: win
84 character(kind=c_char), dimension(*), intent(in), optional :: title
85 type(c_funptr), optional :: destroy, delete_event
86 integer, optional, intent(in) :: border
87 integer, optional, intent(in), dimension(2) :: wsize
88 integer(kind=c_int), intent(in), optional :: sensitive
89
90 win = gtk_window_new (GTK_WINDOW_TOPLEVEL)
91 call gtk_window_set_title(win, title)
92
93 if (present(border)) call gtk_container_set_border_width(win, border)
94 if (present(wsize)) &
95 & call gtk_window_set_default_size(win, wsize(1), wsize(2))
96 if (present(delete_event)) &
97 & call g_signal_connect(win, "delete-event"//CNULL, delete_event)
98 if (present(destroy)) &
99 & call g_signal_connect(win, "destroy"//CNULL, destroy)
100
101 if (present(sensitive)) &
102 & call gtk_widget_set_sensitive(win, sensitive)
103
104 end function hl_gtk_window_new
105
106 function hl_gtk_button_new(label, clicked, data, tooltip, sensitive) &
107 & result(but)
108 ! Higher-level button
109 !
110 ! LABEL: string: required: The label on the button
111 ! CLICKED: c_funloc: optional: callback routine for the "clicked" signal
112 ! DATA: c_loc: optional: Data to be passed to the clicked callback
113 ! TOOLTIP: string: optional: tooltip to be displayed when the pointer
114 ! is held over the button.
115 ! SENSITIVE: logical: optional: Whether the widget should initially
116 ! be sensitive or not.
117
118 type(c_ptr) :: but
119 character(kind=c_char), dimension(*), intent(in) :: label
120 type(c_funptr), optional :: clicked
121 type(c_ptr), optional :: data
122 character(kind=c_char), dimension(*), intent(in), optional :: tooltip
123 integer(kind=c_int), intent(in), optional :: sensitive
124
125 but=gtk_button_new_with_label(label)
126
127 if (present(clicked)) then
128 if (present(data)) then
129 call g_signal_connect(but, "clicked"//CNULL, &
130 & clicked, data)
131 else
132 call g_signal_connect(but, "clicked"//CNULL, &
133 & clicked)
134 end if
135 end if
136
137 if (present(tooltip)) call gtk_widget_set_tooltip_text(but, tooltip)
138 if (present(sensitive)) &
139 & call gtk_widget_set_sensitive(but, sensitive)
140
141 end function hl_gtk_button_new
142
143 function hl_gtk_check_button_new(label, toggled, data, tooltip, &
144 & initial_state, sensitive) result(but)
145 ! Higher level check box.
146 !
147 ! LABEL: string: required: The label on the button.
148 ! TOGGLED: c_funloc: optional: Callback function for the "toggled" signal.
149 ! DATA: c_loc: optional: Data to pass to/from the toggled callback.
150 ! TOOLTIP: string: optional: A tooltip for the check_button.
151 ! INITIAL_STATE: integer: optional: set the initial state of the
152 ! check_button.
153 ! SENSITIVE: logical: optional: Whether the widget should initially
154 ! be sensitive or not.
155
156 type(c_ptr) :: but
157 character(kind=c_char), dimension(*), intent(in) :: label
158 type(c_funptr), optional :: toggled
159 type(c_ptr), optional :: data
160 character(kind=c_char), dimension(*), intent(in), optional :: tooltip
161 integer(kind=c_int), intent(in), optional :: initial_state
162 integer(kind=c_int), intent(in), optional :: sensitive
163
164 but = gtk_check_button_new_with_label(label)
165
166 if (present(toggled)) then
167 if (present(data)) then
168 call g_signal_connect(but, "toggled"//cnull, toggled, data)
169 else
170 call g_signal_connect(but, "toggled"//cnull, toggled)
171 end if
172 end if
173
174 if (present(tooltip)) call gtk_widget_set_tooltip_text(but, tooltip)
175
176 if (present(initial_state)) &
177 & call gtk_toggle_button_set_active(but, initial_state)
178
179 if (present(sensitive)) &
180 & call gtk_widget_set_sensitive(but, sensitive)
181
182 end function hl_gtk_check_button_new
183
184 function hl_gtk_radio_button_new(group, label, toggled, data, tooltip, &
185 & sensitive) result(but)
186 ! Radio button
187 !
188 ! GROUP: c_loc: required: The group to which the button belongs.
189 ! This is an INOUT argument so it must be a variable
190 ! of type(c_ptr). To start a new group (menu) initialize
191 ! the variable to CNULL, to add a new button use the value
192 ! returned from the last call to hl_gtk_radio_button. This
193 ! is the variable which you use to do things like setting the
194 ! selection.
195 ! LABEL: string: required: The label for the button.
196 ! TOGGLED: c_funloc: optional: call back to be executed when the
197 ! button is toggled
198 ! DATA: c_loc: optional: Data to pass to/from the "toggled" callback.
199 ! TOOLTIP: string: optional: A tooltip for the radio button
200 ! SENSITIVE: logical: optional: Whether the widget should initially
201 ! be sensitive or not.
202
203 type(c_ptr) :: but
204 type(c_ptr), intent(inout) :: group
205 character(kind=c_char), dimension(*), intent(in) :: label
206 type(c_funptr), optional :: toggled
207 type(c_ptr), optional :: data
208 character(kind=c_char), dimension(*), intent(in), optional :: tooltip
209 integer(kind=c_int), intent(in), optional :: sensitive
210
211 but = gtk_radio_button_new_with_label(group, label)
212 group = gtk_radio_button_get_group(but)
213
214 if (present(toggled)) then
215 if (present(data)) then
216 call g_signal_connect(but, "toggled"//cnull, toggled, data)
217 else
218 call g_signal_connect(but, "toggled"//cnull, toggled)
219 end if
220 end if
221 if (present(tooltip)) call gtk_widget_set_tooltip_text(but, tooltip)
222
223 if (present(sensitive)) &
224 & call gtk_widget_set_sensitive(but, sensitive)
225
226 end function hl_gtk_radio_button_new
227
228 subroutine hl_gtk_radio_group_set_select(group, index)
229 ! Set the indexth button of a radio group
230 !
231 ! GROUP: c_loc: required: The group of the last button added to
232 ! the radio menu
233 ! INDEX: integer: required: The index of the button to set
234 ! (starting from the first as 0).
235
236 type(c_ptr), intent(in) :: group
237 integer(kind=c_int), intent(in) :: index
238
239 integer(kind=c_int) :: nbuts
240 type(c_ptr) :: datan
241
242 nbuts = g_slist_length(group)
243
244 ! Note that GROUP actually points to the last button added and to the
245 ! group of the next to last & so on
246
247 datan= g_slist_nth_data(group, nbuts-index-1)
248 call gtk_toggle_button_set_active(datan, TRUE)
249
250 end subroutine hl_gtk_radio_group_set_select
251
252 function hl_gtk_radio_group_get_select(group) result(index)
253 ! Find the selected button in a radio group.
254
255 integer(kind=c_int) :: index
256 type(c_ptr), intent(in) :: group
257
258 integer(kind=c_int) :: nbuts, i
259 type(c_ptr) :: but
260
261 nbuts = g_slist_length(group)
262 index=-1
263
264 do i = 1, nbuts
265 but = g_slist_nth_data(group, nbuts-i)
266 if (.not. c_associated(but)) exit
267
268 if (gtk_toggle_button_get_active(but)==TRUE) then
269 index = i-1
270 return
271 end if
272 end do
273 end function hl_gtk_radio_group_get_select
274
275 function hl_gtk_entry_new(len, editable, activate, data, tooltip, value, &
276 & sensitive) result(entry)
277 ! Higher level text entry box
278 !
279 ! LEN: integer: optional: The maximum length of the entry field.
280 ! EDITABLE: logical: optional: whether the entry box can be edited
281 ! by the user
282 ! ACTIVATE: c_funloc: optional: Callback function for the "activate" signal
283 ! DATA: c_loc: optional: Data to be passed to the activate callback
284 ! TOOLTIP: string: optional: tooltip to be displayed when the pointer
285 ! is held over the button.
286 ! VALUE: string: optional: An initial value for the entry box.
287 ! SENSITIVE: logical: optional: Whether the widget should initially
288 ! be sensitive or not.
289
290 type(c_ptr) :: entry
291 integer, intent(in), optional :: len
292 integer(c_int), intent(in), optional :: editable
293 type(c_funptr), optional :: activate
294 type(c_ptr), optional :: data
295 character(kind=c_char), dimension(*), intent(in), optional :: tooltip, value
296 integer(kind=c_int), intent(in), optional :: sensitive
297
298 entry = gtk_entry_new()
299 call gtk_entry_set_activates_default(entry, TRUE)
300
301 if (present(len)) call gtk_entry_set_max_length(entry, len)
302
303 if (present(editable)) &
304 & call gtk_editable_set_editable(entry, editable)
305
306 if (present(activate)) then
307 if (present(data)) then
308 call g_signal_connect(entry, &
309 & "activate"//CNULL, activate, data)
310 else
311 call g_signal_connect(entry, &
312 & "activate"//CNULL, activate)
313 end if
314 end if
315
316 if (present(tooltip)) call gtk_widget_set_tooltip_text(entry, tooltip)
317
318 if (present(value)) call gtk_entry_set_text(entry, value)
319 if (present(sensitive)) &
320 & call gtk_widget_set_sensitive(entry, sensitive)
321
322 end function hl_gtk_entry_new
323
324 function hl_gtk_list1_new(scroll, width, changed, data, multiple, &
325 & sensitive, tooltip, title, height) result(list)
326 ! A single column selectable list based on the GTK Tree View
327 !
328 ! SCROLL: c_ptr: required: The scroll box containing the list
329 ! (used for packing etc.)
330 ! WIDTH: integer: optional: The width of the displayed column.
331 ! CHANGED: c_funptr: optional: Callback function for the "changed"
332 ! signal to the associated selection object.
333 ! DATA: c_ptr: optional: Data to be passed to/from the callback.
334 ! MULTIPLE: logical: optional: Whether multiple selections are allowed.
335 ! SENSITIVE: logical: optional: Whether the widget is intially sensitive.
336 ! TOOLTIP: string: optional: Tooltip for the widget
337 ! TITLE: string: optional: Title for the visible column.
338 ! HEIGHT: integer: optional: The height of the display (this is
339 ! actually the height of the scroll box).
340
341 type(c_ptr) :: list
342 type(c_ptr), intent(out) :: scroll
343 integer(kind=c_int), intent(in), optional :: width
344 type(c_funptr), intent(in), optional :: changed
345 type(c_ptr), intent(in), optional :: data
346 integer(kind=c_int), intent(in), optional :: multiple, sensitive
347 character(kind=c_char), dimension(*), intent(in), optional :: tooltip, title
348 integer(kind=c_int), intent(in), optional :: height
349
350 type(c_ptr), target :: renderer, column, select, model
351 integer(kind=c_int) :: nc
352 integer(kind=type_kind), target, dimension(2) :: types
353
354 ! Create list storage with 2 colums (one is a dummy, to provide an index)
355
356 types = (/ g_type_int, g_type_string /)
357 model = gtk_list_store_newv(2, c_loc(types))
358
359 ! Create visual list inside a scrollbar container
360 scroll = gtk_scrolled_window_new(NULL, NULL)
361 call gtk_scrolled_window_set_policy(scroll, GTK_POLICY_AUTOMATIC, &
362 & GTK_POLICY_AUTOMATIC)
363 list = gtk_tree_view_new_with_model(model)
364 call gtk_container_add(scroll, list)
365
366 ! Insert index column (invisible)
367 renderer = gtk_cell_renderer_text_new()
368 call gtk_cell_renderer_set_visible(renderer, FALSE)
369 column = gtk_tree_view_column_new()
370 call gtk_tree_view_column_pack_start(column, renderer, FALSE)
371 call gtk_tree_view_column_set_title(column, "#"//cnull)
372 call gtk_tree_view_column_add_attribute(column, renderer, &
373 & "text"//CNULL, 0)
374 nc = gtk_tree_view_append_column(list, column)
375 call gtk_tree_view_column_set_sizing (column,GTK_TREE_VIEW_COLUMN_FIXED)
376 call gtk_tree_view_column_set_max_width(column,0)
377
378 ! Insert (visible) column
379
380 renderer = gtk_cell_renderer_text_new()
381 column = gtk_tree_view_column_new()
382 call gtk_tree_view_column_pack_start(column, renderer, FALSE)
383 call gtk_cell_renderer_set_alignment(renderer, 0., 0.)
384 call gtk_cell_renderer_set_padding(renderer, 0, 0)
385 if (present(title)) call gtk_tree_view_column_set_title(column, title)
386 call gtk_tree_view_column_add_attribute(column, renderer, &
387 & "text"//CNULL, 1)
388 nc = gtk_tree_view_append_column(list, column)
389
390 call gtk_tree_view_column_set_reorderable(column, FALSE)
391
392 ! Set sizes if requested. Note that the vertical size is set with the
393 ! scrollable window.
394 if (present(width)) then
395 call gtk_tree_view_column_set_sizing (column, GTK_TREE_VIEW_COLUMN_FIXED)
396 call gtk_tree_view_column_set_fixed_width(column, width)
397 end if
398 if (present(height)) call gtk_widget_set_size_request(scroll,0,height)
399
400 call gtk_tree_view_column_set_resizable(column,TRUE)
401
402 ! The event handler is attached to the selection object, as is
403 ! the multiple selection property.
404
405 select = gtk_tree_view_get_selection(list)
406
407 if (present(multiple)) then
408 if (multiple == TRUE) &
409 & call gtk_tree_selection_set_mode(select, GTK_SELECTION_MULTIPLE)
410 end if
411
412 if (present(changed)) then
413 if (present(data)) then
414 call g_signal_connect(select, "changed"//cnull, changed, data)
415 else
416 call g_signal_connect(select, "changed"//cnull, changed)
417 end if
418 end if
419
420 if (present(tooltip)) call gtk_widget_set_tooltip_text(list, tooltip)
421
422 if (present(sensitive)) &
423 & call gtk_widget_set_sensitive(list, sensitive)
424
425 end function hl_gtk_list1_new
426
427 subroutine hl_gtk_list1_ins(list, text, row)
428 ! Insert a row into a list
429 !
430 ! LIST: g_ptr: required: The list to insert to.
431 ! TEXT: string: required: The text to insert.
432 ! ROW: integer: optional: The row at which to insert the text
433 ! (omit to append)
434
435 type(c_ptr), intent(in) :: list
436 character(kind=c_char), dimension(*), intent(in), target :: text
437 integer(kind=c_int), intent(in), optional :: row
438
439 integer(kind=c_int), target :: i, nrow
440 integer(kind=c_int) :: valid
441
442 type(c_ptr) :: store, val
443 type(gtktreeiter), target :: iter
444 type(gvalue), target :: vali, valt
445
446 ! Get list storage
447 store = gtk_tree_view_get_model(list)
448
449 ! Insert row
450 if (present(row)) then
451 call gtk_list_store_insert(store, c_loc(iter), row)
452 nrow = row
453 else
454 nrow=gtk_tree_model_iter_n_children (store, NULL);
455 call gtk_list_store_append(store, c_loc(iter));
456 end if
457
458 ! Set value
459 val = c_loc(vali)
460 val=g_value_init(val, g_type_int)
461 call g_value_set_int(c_loc(vali), nrow)
462 call gtk_list_store_set_value(store, c_loc(iter), 0, val)
463 val = c_loc(valt)
464 val=g_value_init(val, g_type_string)
465 call g_value_set_static_string(c_loc(valt), text)
466 call gtk_list_store_set_value(store, c_loc(iter), 1, val)
467
468 ! reset the indices for the rest of the list
469 if (present(row)) then
470 i = row
471 do
472 valid = gtk_tree_model_iter_next(store, c_loc(iter))
473 if (valid == FALSE) exit
474 i = i+1
475 call gtk_list_store_set_value(store, c_loc(iter), 0, c_loc(i))
476 end do
477 end if
478 end subroutine hl_gtk_list1_ins
479
480 subroutine hl_gtk_list1_rem(list, row)
481 ! Remove a row or clear a list
482 !
483 ! LIST: g_ptr: required: The list to modify
484 ! ROW: integer: optional: The row to remove, if absent clear the list
485
486 type(c_ptr), intent(in) :: list
487 integer(kind=c_int), optional, intent(in) :: row
488
489 integer(kind=c_int), target :: i
490 integer(kind=c_int) :: valid
491 type(c_ptr) :: store, val
492 type(gtktreeiter), target :: iter
493 type(gvalue), target :: vali
494
495 ! Get list store
496 store = gtk_tree_view_get_model(list)
497
498 ! If 2 arguments, then remove a row
499 if (present(row)) then
500 valid = gtk_tree_model_iter_nth_child(store, c_loc(iter), NULL, row)
501 if (valid==FALSE) return
502
503 valid = gtk_list_store_remove(store, c_loc(iter))
504 if (valid==TRUE) then ! Not the last element
505 i = row
506 val = c_loc(vali)
507 val = g_value_init(val, g_type_int)
508 do
509 call g_value_set_int(val, i)
510 call gtk_list_store_set_value(store, c_loc(iter), 0, val)
511 valid=gtk_tree_model_iter_next(store, c_loc(iter));
512 if (valid==FALSE) exit
513 i=i+1
514 end do
515 end if
516
517 else ! 1 argument clear the whole list
518 call gtk_list_store_clear(store)
519 end if
520 end subroutine hl_gtk_list1_rem
521
522 function hl_gtk_list1_get_selections(list, indices, selection) result(count)
523 ! Get the indices of the selected rows
524 !
525 ! LIST: c_ptr: required: The list whose selections are to be found.
526 ! INDICES: integer: optional: An allocatable array to return the
527 ! list of selections. (If count = 0 it will not be allocated).
528 ! If this argument is not given, then the number of
529 ! selected rows is returned.
530 ! SELECTION: c_ptr: optional: A selection. If this is given then LIST
531 ! is ignored. This is most often used in the callback routine
532 ! for the changed signal when that needs to find which element(s)
533 ! are selected.
534 !
535 ! Returns the number of selections.
536
537 integer(kind=c_int) :: count
538 type(c_ptr), intent(in) :: list
539 integer(kind=c_int), dimension(:), allocatable, target, &
540 & intent(out), optional :: indices
541 type(c_ptr), optional :: selection
542
543 type(c_ptr) :: slist, vselection
544 type(c_ptr), target :: model
545 integer(kind=c_int) :: i
546 type(c_ptr) :: cindex
547 integer(kind=c_int) :: valid
548 type(gtktreeiter), target :: iter
549 type(gvalue), target :: val
550
551 if (present(selection)) then
552 vselection = selection
553 else
554 vselection = gtk_tree_view_get_selection(list)
555 end if
556
557 slist = gtk_tree_selection_get_selected_rows(vselection, &
558 & c_loc(model))
559
560 ! If no selections, then set the count to 0 and return
561 if (.not. c_associated(slist)) then
562 count=0
563 return
564 end if
565
566 ! Determine how many rows are selected. Then if no output list was
567 ! supplied, return, otherwise go on and make a list.
568 count = g_list_length(slist)
569 if (.not. present(indices)) return
570
571 allocate(indices(count))
572
573 ! For each of the elements in the selection list, find its index
574 ! from the hidden first column
575 do i = 1, count
576 valid = gtk_tree_model_get_iter(model, c_loc(iter), &
577 & g_list_nth_data(slist, i-1))
578 call gtk_tree_model_get_value(model, c_loc(iter), 0, c_loc(val))
579 indices(i) = g_value_get_int(c_loc(val))
580 call clear_gvalue(val)
581 end do
582
583 ! Free the selection list.
584 call g_list_foreach(slist, c_funloc(gtk_tree_path_free), NULL)
585 call g_list_free(slist)
586
587 end function hl_gtk_list1_get_selections
588
589 function hl_gtk_menu_new(orientation) result(menu)
590 ! Menu initializer (mainly for consistency)
591 !
592 ! ORIENTATION: integer: optional: Whether to lay out the top level
593 ! horizontaly or vertically. If this arguemtn is present, then
594 ! a menubar is created, otherwise a simple menu.
595
596 type(c_ptr) :: menu
597 integer(kind=c_int), intent(in), optional :: orientation
598
599 integer(kind=c_int) :: orient
600 if (present(orientation)) then
601 orient= orientation
602 else
603 orient = GTK_PACK_DIRECTION_LTR
604 end if
605
606 menu = gtk_menu_bar_new()
607 call gtk_menu_bar_set_pack_direction (menu, orient)
608
609 end function hl_gtk_menu_new
610
611 function hl_gtk_menu_submenu(menu, label, tooltip, pos) result(submenu)
612 ! Make a submenu node
613 !
614 ! MENU: c_ptr: required: The parent of the submenu
615 ! LABEL: string: required: The label of the submenu
616 ! TOOLTIP: string: optional: A tooltip for the submenu.
617 ! POS: integer: optional: The position at which to insert the item
618 ! (omit to append)
619
620 type(c_ptr) :: submenu
621 type(c_ptr) :: menu
622 character(kind=c_char), dimension(*), intent(in) :: label
623 character(kind=c_char), dimension(*), intent(in), optional :: tooltip
624 integer(kind=c_int), optional :: pos
625
626 type(c_ptr) :: item
627
628 ! Create a menu item
629 item = gtk_menu_item_new_with_label(label)
630
631 ! Create a submenu and attach it to the item
632 submenu = gtk_menu_new()
633 call gtk_menu_item_set_submenu(item, submenu)
634
635 ! Insert it to the parent
636 if (present(pos)) then
637 call gtk_menu_shell_insert(menu, item, pos)
638 else
639 call gtk_menu_shell_append(menu, item)
640 end if
641
642 if (present(tooltip)) call gtk_widget_set_tooltip_text(item, tooltip)
643
644 end function hl_gtk_menu_submenu
645
646 function hl_gtk_menu_item(menu, label, activate, data, tooltip, pos) &
647 & result(item)
648 ! Make a menu item or separator
649 !
650 ! MENU: c_ptr: required: The parent menu.
651 ! LABEL: string: optional: The label for the menu, if absent then insert
652 ! a separator.
653 ! ACTIVATE: c_funptr: optional: The callback function for the
654 ! activate signal
655 ! DATA: c_ptr: optional: Data to pass to the callback.
656 ! TOOLTIP: string: optional: A tooltip for the menu item.
657 ! POS: integer: optional: The position at which to insert the item
658 ! (omit to append)
659
660 type(c_ptr) :: item
661 type(c_ptr) :: menu
662 character(kind=c_char), dimension(*), intent(in), optional :: label
663 type(c_funptr), optional :: activate
664 type(c_ptr), optional :: data
665 character(kind=c_char), dimension(*), intent(in), optional :: tooltip
666 integer(kind=c_int), optional :: pos
667
668 ! Create the menu item
669 if (present(label)) then
670 item = gtk_menu_item_new_with_label(label)
671 else
672 item = gtk_separator_menu_item_new()
673 end if
674
675 ! Insert it to the parent
676 if (present(pos)) then
677 call gtk_menu_shell_insert(menu, item, pos)
678 else
679 call gtk_menu_shell_append(menu, item)
680 end if
681
682 ! If present, connect the callback
683 if (present(activate)) then
684 if (.not. present(label)) then
685 print *, "HL_GTK_MENU_ITEM: Cannot connect a callback to a separator"
686 return
687 end if
688
689 if (present(data)) then
690 call g_signal_connect(item, "activate"//cnull, activate, data)
691 else
692 call g_signal_connect(item, "activate"//cnull, activate)
693 end if
694 end if
695
696 ! Attach a tooltip
697 if (present(tooltip)) call gtk_widget_set_tooltip_text(item, tooltip)
698 end function hl_gtk_menu_item
699
700 function hl_gtk_progress_bar_new(orientation, step) result(bar)
701 ! Intializer for a progress bar
702 !
703 ! ORIENTATION: integer: optional: The orientation of the bar.
704 ! STEP: double: optional: The fractional step to advance when
705 ! pulsing the bar
706
707 type(c_ptr) :: bar
708 integer(kind=c_int), optional :: orientation
709 real(kind=c_double), optional :: step
710
711 bar = gtk_progress_bar_new()
712
713 if (present(orientation)) &
714 & call gtk_progress_bar_set_orientation(bar, orientation)
715
716 if (present(step)) &
717 & call gtk_progress_bar_set_pulse_step(bar, step)
718
719 end function hl_gtk_progress_bar_new
720
721 subroutine hl_gtk_progress_bar_set_f(bar, val, string, text)
722 ! Set the value of a progress bar
723 !
724 ! BAR: c_ptr: required: The bar to set
725 ! VAL: double: optional: The value to set. If absent, the bar is pulsed
726 ! STRING: logical: optional: Whether to put a string on the bar.
727 ! TEXT: string: optional: Text to put in the bar, (overrides STRING)
728
729 type(c_ptr) :: bar
730 real(kind=c_double), optional :: val
731 integer(kind=c_int), optional :: string
732 character(kind=c_char), dimension(*), intent(in), optional :: text
733
734 real(kind=c_double) :: frac
735 character(len=50) :: sval
736
737 ! If no value given pulse the bar
738 if (.not. present(val)) then
739 call gtk_progress_bar_pulse(bar)
740 else
741
742 ! Determine the fraction to fill & fill it
743 call gtk_progress_bar_set_fraction(bar, val)
744 end if
745
746 ! If annotation is needed, add it.
747 if (present(text)) then
748 call gtk_progress_bar_set_text (bar, text)
749 else if (present(string)) then
750 if (string == FALSE .or. .not. present(val)) return
751 ! Otherwise we display a percentage
752 write(sval, "(F5.1,'%')") val*100.
753
754 call gtk_progress_bar_set_text (bar, trim(sval)//cnull)
755 end if
756 end subroutine hl_gtk_progress_bar_set_f
757 subroutine hl_gtk_progress_bar_set_ii(bar, val, maxv, string, text)
758 ! Set the value of a progress bar
759 !
760 ! BAR: c_ptr: required: The bar to set
761 ! VAL: int: required: The value to set. If absent, the bar is pulsed
762 ! MAXV: int: required: The maximum value for the bar
763 ! STRING: logical: optional: Whether to put a string on the bar.
764 ! TEXT: string: optional: Text to put in the bar, (overrides STRING)
765
766 type(c_ptr) :: bar
767 integer(kind=c_int) :: val, maxv
768 integer(kind=c_int), optional :: string
769 character(kind=c_char), dimension(*), intent(in), optional :: text
770
771 real(kind=c_double) :: frac
772 character(len=50) :: sval
773
774 frac = real(val,c_double)/real(maxv,c_double)
775 call gtk_progress_bar_set_fraction(bar, frac)
776
777 ! If annotation is needed, add it.
778 if (present(text)) then
779 call gtk_progress_bar_set_text (bar, text)
780 else if (present(string)) then
781 if (string == FALSE) return
782 ! Otherwise we display n or m
783 write(sval, "(I0,' of ',I0)") val, maxv
784 call gtk_progress_bar_set_text (bar, trim(sval)//cnull)
785 end if
786 end subroutine hl_gtk_progress_bar_set_ii
787
788 end module gtk_hl
Something went wrong with that request. Please try again.