1 (* GTK Demo for Pascal
2 *
3 * Welcome to GTK Demo for Pascal.
4 *
5 *
6 * This demo is an adaption of the GTK Demo included in the GTK+-2.0 source.
7 * A new feature is syntax highligting for pascal.
8 *)
9
10 program gtk_demo;
11
12 {$mode objfpc} {$H+}
13 uses glib2, pango, gdk2, gtk2, gdk2pixbuf, strings, math;
14
15 var
16 info_buffer : PGtkTextBuffer;
17 source_buffer : PGtkTextBuffer;
18 current_file : pgchar;
19
20
21
22 type
23 TFileOfChar = file of char;
24
25 TGDoDemoFunc = function : PGtkWidget;
26
27 PDemo = ^TDemo;
28 TDemo = record
29 title : pgchar;
30 filename : pgchar;
31 func : TGDoDemoFunc;
32 children : PDemo;
33 end;
34
35 PCallbackData = ^TCallbackData;
36 TCallbackData = record
37 model : PGtkTreeModel;
38 path : PGtkTreePath;
39 end;
40
41 const
42
43 DEMO_DATA_DIR = 'data';
44
45 TITLE_COLUMN = 0;
46 FILENAME_COLUMN = 1;
47 FUNC_COLUMN = 2;
48 ITALIC_COLUMN = 3;
49 NUM_COLUMNS = 4;
50
51 STATE_NORMAL = 0;
52 STATE_IN_COMMENT = 1;
53
54 function demo_find_file ( base : pchar; err : PPGError): pgchar; forward;
55
56 (* file_is_valid
57 * a dirty little hack to find out if a file variable is assigned and the
58 * file is opened.
59 *)
file_is_validnull60 function file_is_valid (var f: file): boolean;
61 begin
62 {$push}{$I-}
63 if eof(f) then
64 exit (TRUE);
65 {$pop}
66 if IOResult <> 0 then
67 file_is_valid := FALSE
68 else
69 file_is_valid := TRUE;
70 end;
71
72 (* min, max
73 * these two functions of the math unit are overloaded to understand double
74 * values.
75 *)
minnull76 function min (d1, d2: double): double;
77 begin
78 if d1 > d2 then min := d2
79 else min := d1;
80 end;
81
maxnull82 function max (d1, d2: double): double;
83 begin
84 if d1 < d2 then max := d2
85 else max := d1;
86 end;
87
88 (* do_dummy
89 * creates a widget informing the user that the demo isn't implemented, yet
90 *)
91
92 procedure do_dummy (demo : pgchar);
93 var
94 dialog : PGtkWidget;
95 begin
96 dialog := gtk_message_dialog_new (NULL, 0,
97 GTK_MESSAGE_INFO,
98 GTK_BUTTONS_CLOSE,
99 'Sorry, "%s" is''t implemented, yet.',
100 [demo]);
101
102 gtk_widget_show (dialog);
103
104 g_signal_connect (dialog, 'response',
105 G_CALLBACK (@gtk_widget_destroy), NULL);
106 end;
107
108 (* include the modules here;
109 * if you'd like to add one add the include command and
110 * create a new entry in the testgtk_demos array
111 *)
112
113 {$include appwindow.inc}
114 {$include button_box.inc}
115 {$include colorsel.inc}
116 {$include dialog.inc}
117 {$include drawingarea.inc}
118 {$include editable_cells.inc}
119 {$include images.inc}
120 {$include item_factory.inc}
121 {$include list_store.inc}
122 {$include menus.inc}
123 {$include panes.inc}
124 {$include pixbufs.inc}
125 {$include sizegroup.inc}
126 {$include stock_browser.inc}
127 {$include textview.inc}
128 {$include tree_store.inc}
129
130
131 const
132 child0 : array [1..4] of TDemo = (
133 (title: 'Editable Cells'; filename: 'editable_cells.inc'; func: @do_editable_cells; children: nil),
134 (title: 'List Store'; filename: 'list_store.inc'; func: @do_list_store; children: nil),
135 (title: 'Tree Store'; filename: 'tree_store.inc'; func: @do_tree_store; children: nil),
136 (title: nil; filename: nil; func: nil; children: nil));
137
138 testgtk_demos: array [1..16] of TDemo = (
139 (title: '* This Application *'; filename: 'gtk_demo.pas'; func: nil; children: nil),
140 (title: 'Application main window'; filename: 'appwindow.inc'; func: @do_appwindow; children: nil),
141 (title: 'Button Boxes'; filename: 'button_box.inc'; func: @do_button_box; children: nil),
142 (title: 'Color Selector'; filename: 'colorsel.inc'; func: @do_colorsel; children: nil),
143 (title: 'Dialog and Message Boxes'; filename: 'dialog.inc'; func: @do_dialog; children: nil),
144 (title: 'Drawing Area'; filename: 'drawingarea.inc'; func: @do_drawingarea; children: nil),
145 (title: 'Images'; filename: 'images.inc'; func: @do_images; children: nil),
146 (title: 'Item Factory'; filename: 'item_factory.inc'; func: @do_item_factory; children: nil),
147 (title: 'Menus'; filename: 'menus.inc'; func: @do_menus; children: nil),
148 (title: 'Paned Widgets'; filename: 'panes.inc'; func: @do_panes; children: nil),
149 (title: 'Pixbufs'; filename: 'pixbufs.inc'; func: @do_pixbufs; children: nil),
150 (title: 'Size Groups'; filename: 'sizegroup.inc'; func: @do_sizegroup; children: nil),
151 (title: 'Stock Item and Icon Browser'; filename: 'stock_browser.inc'; func: @do_stock_browser; children: nil),
152 (title: 'Text Widget'; filename: 'textview.inc'; func: @do_textview; children: nil),
153 (title: 'Tree View'; filename: nil; func: nil; children: @child0),
154 (title: nil; filename: nil; func: nil; children: nil));
155
156
demo_find_filenull157 function demo_find_file ( base : pchar;
158 err : PPGError): pgchar;
159 var
160 filename : pchar;
161
162 begin
163
164 if g_file_test (base, G_FILE_TEST_EXISTS) then begin
165 demo_find_file := g_strdup (base);
166 exit;
167 end else
168 begin
169 filename := g_build_filename (DEMO_DATA_DIR, [ base, NULL ]);
170
171 if not (g_file_test (filename, G_FILE_TEST_EXISTS)) then
172 begin
173 g_set_error (err, G_FILE_ERROR, G_FILE_ERROR_NOENT,
174 'Cannot find demo data file "%s"', [base]);
175 g_free (filename);
176 demo_find_file := NULL;
177 end else
178 demo_find_file := filename;
179 end;
180 end;
181
182
create_textnull183 function create_text (var buffer : PGtkTextBuffer;
184 is_source : gboolean): PGtkWidget;
185 var
186 scrolled_window,
187 text_view : PGtkWidget;
188
189 font_desc : PPangoFontDescription;
190
191 begin
192 scrolled_window := gtk_scrolled_window_new (NULL, NULL);
193
194 gtk_scrolled_window_set_policy (GTK_SCROLLED_WINDOW (scrolled_window),
195 GTK_POLICY_AUTOMATIC,
196 GTK_POLICY_AUTOMATIC);
197
198 gtk_scrolled_window_set_shadow_type (GTK_SCROLLED_WINDOW (scrolled_window),
199 GTK_SHADOW_IN);
200
201 text_view := gtk_text_view_new;
202
203 buffer := gtk_text_buffer_new (NULL);
204
205 gtk_text_view_set_buffer (GTK_TEXT_VIEW (text_view), buffer);
206 gtk_text_view_set_editable (GTK_TEXT_VIEW (text_view), FALSE);
207 gtk_text_view_set_cursor_visible (GTK_TEXT_VIEW (text_view), FALSE);
208
209 gtk_container_add (GTK_CONTAINER (scrolled_window), text_view);
210
211 if is_source then
212 begin
213 font_desc := pango_font_description_from_string ('Courier 12');
214 gtk_widget_modify_font (text_view, font_desc);
215 pango_font_description_free (font_desc);
216
217 gtk_text_view_set_wrap_mode (GTK_TEXT_VIEW (text_view),
218 GTK_WRAP_NONE);
219 end else
220 begin
221 (* Make it a bit nicer for text. *)
222 gtk_text_view_set_wrap_mode (GTK_TEXT_VIEW (text_view),
223 GTK_WRAP_WORD);
224 gtk_text_view_set_pixels_above_lines (GTK_TEXT_VIEW (text_view), 2);
225 gtk_text_view_set_pixels_below_lines (GTK_TEXT_VIEW (text_view), 2);
226 end;
227
228 create_text := scrolled_window;
229 end;
230
231
232 const
233 tokens: array [1..4] of pgchar =
234 ('(*',
235 '''',
236 '{',
237 '//');
238
239 types: array [1..57] of pgchar =
240 ('integer',
241 'gchar',
242 'pgchar',
243 'char',
244 'gfloat',
245 'real',
246 'gint8',
247 'gint16',
248 'gint32',
249 'gint',
250 'guint',
251 'guint8',
252 'guint16',
253 'guint32',
254 'guchar',
255 'glong',
256 'longint',
257 'gboolean' ,
258 'gshort',
259 'gushort',
260 'gulong',
261 'gdouble',
262 'double',
263 'gldouble',
264 'gpointer',
265 'pointer',
266 'NULL',
267 'nil',
268 'PGList',
269 'TGList',
270 'TGSList',
271 'PGSList',
272 'FALSE',
273 'TRUE',
274 'PGtkObject',
275 'TGtkObject',
276 'TGtkColorSelection',
277 'PGtkColorSelection',
278 'PGtkWidget',
279 'TGtkWidget',
280 'PGtkButton',
281 'TGtkButton',
282 'TGdkColor',
283 'PGdkColor',
284 'TGdkRectangle',
285 'PGdkRectangle',
286 'TGdkEventExpose',
287 'PGdkEventExpose',
288 'TGdkGC',
289 'PGdkGC',
290 'TGdkPixbufLoader',
291 'PGdkPixbufLoader',
292 'TGdkPixbuf',
293 'PGdkPixbuf',
294 'PPGError',
295 'PGError',
296 'array');
297
298 control: array [1..23] of pgchar = (
299 'if',
300 'then',
301 'case',
302 'while',
303 'else',
304 'do',
305 'for',
306 'begin',
307 'end',
308 'exit',
309 'goto',
310 'program',
311 'unit',
312 'library',
313 'procedure',
314 'function',
315 'type',
316 'var',
317 'const',
318 'record',
319 'uses',
320 'of',
321 'in');
322
323 procedure parse_chars ( text : pgchar;
324 var end_ptr : pgchar;
325 var state : gint;
326 var tag : pgchar;
327 start : gboolean);
328 var
329 i : gint;
330 next_token : pgchar;
331
332 maybe_escape : boolean;
333 begin
334 (* leave out leading spaces *)
335 while (text^ <> #0) and (g_ascii_isspace (text^)) do
336 inc (text);
337
338 (* Handle comments first *)
339
340 if state = STATE_IN_COMMENT then
341 begin
342 end_ptr := StrPos (text, '*)');
343 next_token := StrPos (text, '}');
344
345 if next_token > end_ptr then begin
346 end_ptr := next_token + 1; // '}' comment type
347 state := STATE_NORMAL;
348 tag := 'comment';
349 end else
350 if end_ptr <> NULL then
351 begin
352 end_ptr := end_ptr + 2; // '* )' comment type
353 state := STATE_NORMAL;
354 tag := 'comment';
355 end;
356
357 exit;
358 end;
359
360 tag := NULL;
361 end_ptr := NULL;
362
363 if text^ = #0 then
364 exit;
365
366 (* check for preprocessor defines *)
367
368 if (((StrLComp (text, '(*', 2)) = 0) and (text[2] = '$') ) or
369 (((StrLComp (text, '{', 1)) = 0) and (text[1] = '$') ) then
370 begin
371 end_ptr := StrPos (text, '*)');
372 next_token := StrPos (text, '}');
373
374 if next_token > end_ptr then
375 end_ptr := next_token + 1
376 else
377 if end_ptr <> NULL then
378 end_ptr := end_ptr + 2;
379
380 tag := 'preprocessor';
381 exit;
382 end;
383
384
385
386 (* check for comment *)
387
388 if ((StrLComp (text, '(*', 2)) = 0) or
389 ((StrLComp (text, '{', 1)) = 0) then
390 begin
391 end_ptr := StrPos (text, '*)');
392 next_token := StrPos (text, '}');
393
394 if next_token > end_ptr then
395 end_ptr := next_token+1
396 else begin
397 if end_ptr <> NULL then
398 end_ptr := end_ptr + 2
399 else
400 state := STATE_IN_COMMENT;
401 end;
402 tag := 'comment';
403 exit;
404 end;
405
406 if (StrLComp (text, '//', 2)) = 0 then
407 begin
408 end_ptr := NULL;
409 tag := 'comment';
410 exit;
411 end;
412
413 (* check for types *)
414
415 for i := 1 to high (types) do
416 if ((StrLComp (text, types[i], strlen (types[i]))) = 0 ) and
417 ((text+strlen(types[i]))^ in [#8, #32, #0, ';', #13, #10, ')', ']', ':']) then
418 begin
419 end_ptr := text + strlen (types[i]);
420 tag := 'type';
421 exit;
422 end;
423
424 (* check for control *)
425 for i := 1 to high (control) do begin
426 if ((StrLComp (text, control[i], strlen (control[i]))) = 0) and
427 ((text+strlen(control[i]))^ in [#8, #32, #0, ';', #13, #10, ')', ']', ':']) then
428 begin
429 end_ptr := text + strlen (control[i]);
430 tag := 'control';
431 exit;
432 end;
433 end;
434
435 (* check for string *)
436 if text^= '''' then
437 begin
438 maybe_escape := FALSE;
439
440 end_ptr := text + 1;
441 tag := 'string';
442
443 while end_ptr^ <> #0 do
444 begin
445 if (end_ptr^ = '''') and (maybe_escape = FALSE) then
446 begin
447 inc (end_ptr);
448 exit;
449 end;
450
451 if end_ptr^ = '\' then
452 maybe_escape := TRUE
453 else
454 maybe_escape := FALSE;
455
456 inc (end_ptr);
457 end;
458 exit;
459 end;
460
461
462 (* not at the start of a tag. Find the next one. *)
463 for i := 1 to high(tokens) do
464 begin
465 next_token := StrPos (text, tokens[i]);
466 if next_token <> NULL then
467 begin
468 if end_ptr <> NULL then
469 begin
470 if end_ptr > next_token then
471 end_ptr := next_token;
472 end else
473 end_ptr := next_token;
474 end;
475 end;
476
477 for i := 1 to high(types) do
478 begin
479 next_token := StrPos (text, types[i]);
480 if next_token <> NULL then
481 if ( (next_token+strlen(types[i]))^
482 in [#8, #32, #0, ';', #13, #10, ')', ']', ':']) and
483 g_ascii_isspace ((next_token-1)^) then
484 begin
485 if end_ptr <> NULL then
486 begin
487 if end_ptr > next_token then
488 end_ptr := next_token;
489 end else
490 end_ptr := next_token;
491 end;
492 end;
493
494
495 for i := 1 to high(control) do
496 begin
497 next_token := StrPos (text, control[i]);
498 if next_token <> NULL then
499 if ( (next_token+strlen(control[i]))^
500 in [#8, #32, #0, ';', #13, #10, ')', ']', ':']) and
501 g_ascii_isspace ((next_token-1)^) then
502 begin
503 if end_ptr <> NULL then
504 begin
505 if end_ptr > next_token then
506 end_ptr := next_token;
507 end else
508 end_ptr := next_token;
509 end;
510 end;
511 end;
512
513
514 (* While not as cool as c-mode, this will do as a quick attempt at highlighting *)
515
516 procedure fontify;
517
518 var
519 start_iter,
520 next_iter,
521 tmp_iter : TGtkTextIter;
522
523 state : gint;
524 text : pgchar;
525 start_ptr,
526
527 end_ptr : pgchar;
528 tag : pgchar;
529 start : gboolean;
530
531 begin
532 state := STATE_NORMAL;
533
534 gtk_text_buffer_get_iter_at_offset (source_buffer, @start_iter, 0);
535
536 next_iter := start_iter;
537
538 while (gtk_text_iter_forward_line (@next_iter)) do
539 begin
540 start := TRUE;
541 text := gtk_text_iter_get_text ( @start_iter, @next_iter);
542 start_ptr := text;
543
544 repeat
545 parse_chars (start_ptr, end_ptr, state, tag, start);
546
547 start := FALSE;
548 if end_ptr <> NULL then begin
549 tmp_iter := start_iter;
550 gtk_text_iter_forward_chars (@tmp_iter, end_ptr - start_ptr);
551 end else
552 tmp_iter := next_iter;
553
554 if tag <> NULL then
555 gtk_text_buffer_apply_tag_by_name (source_buffer, tag, @start_iter, @tmp_iter);
556
557 start_iter := tmp_iter;
558 start_ptr := end_ptr;
559 until end_ptr = NULL;
560
561 g_free (text);
562 start_iter := next_iter;
563 end;
564 end;
565
read_linenull566 function read_line (var f: TFileOfChar; str: PGString): boolean;
567 var
568 n_read : integer;
569 c,
570 next_c : char;
571
572 begin
573 n_read := 0;
574
575 g_string_truncate (str, 0);
576
577 while not eof(f) do begin
578 read (f, c);
579
580 inc (n_read);
581
582 if (c = #10) or (c = #13) then
583 begin
584 if not eof(f) then
585 begin
586 read (f, next_c);
587
588 if not ((next_c in [#13, #10]) and (c <> next_c)) then
589 seek(f, filepos(f)-1);
590 break;
591 end;
592 end else
593 g_string_append_c (str, c);
594 end;
595
596 read_line := n_read > 0;
597 end;
598
599
600
601 (* opens a textfile and reads it into the TGtkTextBuffer *)
602 procedure load_file (filename : pgchar);
603
604 var
605 text_start,
606 text_end : TGtkTextIter;
607
608 err : PGError;
609 buffer : PGString;
610 state,
611 len_chars,
612 len : integer;
613
614 in_para : gboolean;
615 f : TFileOfChar;
616 full_name : pchar;
617 p, q, r : pgchar;
618
619 begin
620
621 err := NULL;
622 buffer := g_string_new (NULL);
623 state := 0;
624 in_para := FALSE;
625
626 if (current_file <> NULL) and (StrComp (current_file, filename) = 0) then begin
627 g_string_free (buffer, TRUE);
628 exit;
629 end;
630
631 g_free (current_file);
632 current_file := g_strdup (filename);
633
634 gtk_text_buffer_get_bounds (info_buffer, @text_start, @text_end);
635 gtk_text_buffer_delete (info_buffer, @text_start, @text_end);
636
637 gtk_text_buffer_get_bounds (source_buffer, @text_start, @text_end);
638 gtk_text_buffer_delete (source_buffer, @text_start, @text_end);
639
640 full_name := demo_find_file (filename, @err);
641
642 if full_name = NULL then begin
643 g_warning ('%s', [err^.message]);
644 g_error_free (err);
645 exit;
646 end;
647
648 {$push}{$I-}
649 assign (f, full_name);
650 reset (f);
651 {$pop}
652
653 if IOResult <> 0 then
654 g_print ('Cannot open %s: file not found'#13#10, [full_name]);
655
656 g_free (full_name);
657
658 if IOResult <> 0 then
659 exit;
660
661 gtk_text_buffer_get_iter_at_offset (info_buffer, @text_start, 0);
662
663 while read_line (f, buffer) do
664 begin
665 p := buffer^.str;
666
667 case state of
668 0 : begin (* Reading title *)
669
670 while (((p^ = '(') or (p^ = '*')) or (p^ = '{')) or g_ascii_isspace (p^) do
671 inc (p);
672 r := p;
673
674 while (r^ <> ')') and (strlen (r) > 0) do
675 inc (r);
676
677 if strlen (r) > 0 then
678 p := r + 1;
679
680 q := p + strlen (p);
681
682 while (q > p) and g_ascii_isspace ((q - 1)^) do
683 dec(q);
684
685 if q > p then
686 begin
687 len_chars := g_utf8_pointer_to_offset (p, q);
688
689 text_end := text_start;
690
691 // g_assert (strlen (p) >= (q - p));
692
693 gtk_text_buffer_insert (info_buffer, @text_end, p, q - p);
694 text_start := text_end;
695
696 gtk_text_iter_backward_chars (@text_start, len_chars);
697 gtk_text_buffer_apply_tag_by_name (info_buffer, 'title', @text_start, @text_end);
698
699 text_start := text_end;
700
701 inc (state);
702 end; {of q > p }
703 end; {of state = 0}
704
705
706 1: begin (* Reading body of info section *)
707 while g_ascii_isspace (p^) do
708 inc(p);
709
710 if (p^ = '*') and ((p + 1)^ = ')') then
711 begin
712 gtk_text_buffer_get_iter_at_offset (source_buffer, @text_start, 0);
713 inc(state);
714 end else
715 begin
716 while (p^ = '*') or g_ascii_isspace (p^) do
717 inc(p);
718
719 len := strlen (p);
720
721 while g_ascii_isspace ( (p + len - 1)^) do
722 dec (len);
723
724 if len > 0 then
725 begin
726
727 if in_para then
728 gtk_text_buffer_insert (info_buffer, @text_start, ' ', 1);
729
730 // g_assert (strlen (p) >= len);
731
732 gtk_text_buffer_insert (info_buffer, @text_start, p, len);
733
734 in_para := TRUE;
735 end else
736 begin
737 gtk_text_buffer_insert (info_buffer, @text_start, #10, 1);
738 in_para := FALSE;
739 end; {else len <= 0}
740 end;
741 end;
742 2: begin (* Skipping blank lines *)
743 while g_ascii_isspace (p^) do
744 inc(p);
745
746 if p^ <> #0 then
747 begin
748 p := buffer^.str;
749 inc (state); (* Fall through *)
750
751 (* Reading program body *)
752 gtk_text_buffer_insert (source_buffer, @text_start, p, -1);
753 gtk_text_buffer_insert (source_buffer, @text_start, #10, 1);
754 end;
755 end;
756
757 3: begin (* Reading program body *)
758 gtk_text_buffer_insert (source_buffer, @text_start, p, -1);
759 gtk_text_buffer_insert (source_buffer, @text_start, #10, 1);
760 end;
761 end;
762 end;
763
764 close (f);
765 fontify ();
766
767 g_string_free (buffer, TRUE);
768 end;
769
770 (* some callbacks *)
771
772 procedure window_closed_cb (window : PGtkWidget;
773 data : gpointer); cdecl;
774 var
775 cbdata : PCallbackData;
776 iter : TGtkTreeIter;
777 italic,
778 nitalic : gboolean;
779
780 begin
781 cbdata := data;
782
783 gtk_tree_model_get_iter (cbdata^.model, @iter, cbdata^.path);
784 gtk_tree_model_get (GTK_TREE_MODEL (cbdata^.model), @iter,
785 [ ITALIC_COLUMN, @italic, -1] );
786 nitalic := not italic;
787
788 if italic then
789 gtk_tree_store_set (GTK_TREE_STORE (cbdata^.model), @iter,
790 [ ITALIC_COLUMN, nitalic, -1] );
791
792 gtk_tree_path_free (cbdata^.path);
793 dispose (cbdata);
794
795 end;
796
797
798
799 procedure row_activated_cb (tree_view : PGtkTreeView;
800 path : PGtkTreePath;
801 column : PGtkTreeViewColumn); cdecl;
802 var
803 iter : TGtkTreeIter;
804 italic,
805 nitalic : gboolean;
806 func : TGDoDemoFunc;
807 window : PGtkWidget;
808 model : PGtkTreeModel;
809 cbdata : PCallbackData;
810
811 begin
812 model := gtk_tree_view_get_model (tree_view);
813
814 gtk_tree_model_get_iter (model, @iter, path);
815 gtk_tree_model_get (GTK_TREE_MODEL (model),
816 @iter,
817 [ FUNC_COLUMN, @func,
818 ITALIC_COLUMN, @italic, -1 ]);
819
820 if func <> NULL then
821 begin
822 nitalic := not italic;
823 gtk_tree_store_set (GTK_TREE_STORE (model),
824 @iter,
825 [ ITALIC_COLUMN, nitalic, -1 ] );
826
827 window := func();
828
829 if window <> NULL then
830 begin
831 new (cbdata);
832 cbdata^.model := model;
833
834 cbdata^.path := gtk_tree_path_copy (path);
835
836 g_signal_connect (window, 'destroy',
837 G_CALLBACK (@window_closed_cb), cbdata );
838 end;
839 end;
840 end;
841
842
843 procedure selection_cb ( selection : PGtkTreeSelection;
844 model : PGtkTreeModel); cdecl;
845 var
846 iter : TGtkTreeIter;
847 // value : TGValue;
848 str : pgchar;
849
850 begin
851
852 (* g_value_init(@value, G_TYPE_STRING); // added to test if TGValue works
853 // -- its seems not as if it does *)
854
855 if not gtk_tree_selection_get_selected (selection, NULL, @iter) then
856 exit;
857
858 (* The original code used TGValue but it seems not to work; check why *)
859
860 (*
861 gtk_tree_model_get_value (model, @iter, FILENAME_COLUMN, @value);
862
863 if (g_value_get_string (@value)) <> NULL then
864 load_file (g_value_get_string (@value));
865
866 g_value_unset (@value);
867 *)
868
869 gtk_tree_model_get (model, @iter, [FILENAME_COLUMN, @str, -1]);
870
871 if str <> NULL then
872 load_file (str);
873
874 end;
875
876
create_treenull877 function create_tree: PGtkWidget;
878
879 var
880 selection : PGtkTreeSelection;
881 cell : PGtkCellRenderer;
882 tree_view : PGtkWidget;
883 column : PGtkTreeViewColumn;
884 model : PGtkTreeStore;
885
886 iter,
887 child_iter : TGtkTreeIter;
888
889 d,
890 children : PDemo;
891
892 begin
893 d := @testgtk_demos;
894
895 model := gtk_tree_store_new (NUM_COLUMNS, [G_TYPE_STRING, G_TYPE_STRING, G_TYPE_POINTER, G_TYPE_BOOLEAN]);
896
897 tree_view := gtk_tree_view_new ();
898
899 gtk_tree_view_set_model (GTK_TREE_VIEW (tree_view), GTK_TREE_MODEL (model));
900 selection := gtk_tree_view_get_selection (GTK_TREE_VIEW (tree_view));
901
902 gtk_tree_selection_set_mode (GTK_TREE_SELECTION (selection),
903 GTK_SELECTION_BROWSE);
904
905 gtk_widget_set_size_request (tree_view, 200, -1);
906
907 (* this code only supports 1 level of children. If we
908 * want more we probably have to use a recursing function.
909 *)
910
911
912 while d^.title <> NULL do begin
913 children := d^.children;
914
915 gtk_tree_store_append (GTK_TREE_STORE (model), @iter, NULL);
916
917 gtk_tree_store_set (GTK_TREE_STORE (model),
918 @iter,
919 [ TITLE_COLUMN, d^.title,
920 FILENAME_COLUMN, d^.filename,
921 FUNC_COLUMN, d^.func,
922 ITALIC_COLUMN, FALSE, -1 ] );
923
924 inc(d);
925
926 if children = NULL then
927 continue;
928
929 while children^.title <> NULL do begin
930
931 gtk_tree_store_append (GTK_TREE_STORE (model), @child_iter, @iter);
932
933 gtk_tree_store_set (GTK_TREE_STORE (model),
934 @child_iter,
935 [TITLE_COLUMN, children^.title,
936 FILENAME_COLUMN, children^.filename,
937 FUNC_COLUMN, children^.func,
938 ITALIC_COLUMN, FALSE, -1]);
939 inc (children);
940 end;
941 end;
942
943 cell := gtk_cell_renderer_text_new ();
944
945 g_object_set (G_OBJECT (cell),
946 'style', [ PANGO_STYLE_ITALIC, NULL ]);
947
948
949 column := gtk_tree_view_column_new_with_attributes ('Widget (double click for demo)',
950 cell,
951 [ 'text', TITLE_COLUMN,
952 'style_set', ITALIC_COLUMN, NULL ] );
953
954 gtk_tree_view_append_column (GTK_TREE_VIEW (tree_view),
955 GTK_TREE_VIEW_COLUMN (column));
956
957 g_signal_connect (selection, 'changed', G_CALLBACK (@selection_cb), model);
958 g_signal_connect (tree_view, 'row_activated', G_CALLBACK (@row_activated_cb), model);
959
960 gtk_tree_view_expand_all (GTK_TREE_VIEW (tree_view));
961
962 create_tree := tree_view;
963 end;
964
965
966 procedure setup_default_icon;
967 var
968 pixbuf : PGdkPixbuf;
969 filename : pchar;
970 err : PGError;
971
972 dialog : PGtkWidget;
973
974 list : PGList;
975 transparent : PGdkPixbuf;
976
977 begin
978 err := NULL;
979 pixbuf := NULL;
980 dialog := NULL;
981
982 filename := demo_find_file ('gtk-logo-rgb.gif', @err);
983
984 if filename <> NULL then
985 begin
986 pixbuf := gdk_pixbuf_new_from_file (filename, @err);
987 g_free (filename);
988 end;
989
990 (* Ignoring this error (passing NULL instead of &err above)
991 * would probably be reasonable for most apps. We're just
992 * showing off.
993 *)
994
995 if err <> NULL then
996 begin
997 dialog := gtk_message_dialog_new (NULL, 0,
998 GTK_MESSAGE_ERROR,
999 GTK_BUTTONS_CLOSE,
1000 'Failed to read icon file: %s',
1001 [err^.message]);
1002 gtk_widget_show (dialog);
1003 g_error_free (err);
1004
1005 g_signal_connect (dialog, 'response',
1006 G_CALLBACK (@gtk_widget_destroy), NULL);
1007 end;
1008
1009 if pixbuf <> NULL then
1010 begin
1011 (* The gtk-logo-rgb icon has a white background, make it transparent *)
1012
1013 transparent := gdk_pixbuf_add_alpha (pixbuf, TRUE, $ff, $ff, $ff);
1014
1015 list := NULL;
1016 list := g_list_append (list, transparent);
1017
1018 gtk_window_set_default_icon_list (list);
1019
1020 g_list_free (list);
1021 g_object_unref (G_OBJECT (pixbuf));
1022 g_object_unref (G_OBJECT (transparent));
1023 end;
1024 end;
1025
1026
1027
1028 var
1029 window,
1030 notebook,
1031 hbox,
1032 tree : PGtkWidget;
1033
1034 begin
1035 current_file := NULL;
1036
1037 {$include init.inc} (* contains all variable inits of the demos *)
1038
1039 gtk_init (@argc, @argv);
1040
1041 setup_default_icon ();
1042
1043 window := gtk_window_new (GTK_WINDOW_TOPLEVEL);
1044
1045 gtk_window_set_title (GTK_WINDOW (window), 'GTK+ Code Demos');
1046
1047 g_signal_connect (window, 'destroy',
1048 G_CALLBACK (@gtk_main_quit), NULL);
1049
1050 hbox := gtk_hbox_new (FALSE, 0);
1051 gtk_container_add (GTK_CONTAINER (window), hbox);
1052
1053 tree := create_tree;
1054
1055 gtk_box_pack_start (GTK_BOX (hbox), tree, FALSE, FALSE, 0);
1056
1057 notebook := gtk_notebook_new;
1058 gtk_box_pack_start (GTK_BOX (hbox), notebook, TRUE, TRUE, 0);
1059
1060 gtk_notebook_append_page (GTK_NOTEBOOK (notebook),
1061 create_text (info_buffer, FALSE),
1062 gtk_label_new_with_mnemonic ('_Info'));
1063
1064
1065 gtk_notebook_append_page (GTK_NOTEBOOK (notebook),
1066 create_text (source_buffer, TRUE),
1067 gtk_label_new_with_mnemonic ('_Source'));
1068
1069 gtk_text_buffer_create_tag (info_buffer, 'title', 'font', ['Sans 18', NULL ]);
1070
1071 gtk_text_buffer_create_tag (source_buffer, 'comment', 'foreground', ['red', NULL]);
1072
1073 gtk_text_buffer_create_tag (source_buffer, 'type', 'foreground', ['ForestGreen', NULL]);
1074
1075 gtk_text_buffer_create_tag (source_buffer, 'string', 'foreground',
1076 ['RosyBrown', 'weight', PANGO_WEIGHT_BOLD, NULL]);
1077
1078 gtk_text_buffer_create_tag (source_buffer, 'control', 'foreground', ['purple', NULL]);
1079
1080 gtk_text_buffer_create_tag (source_buffer, 'preprocessor', 'style',
1081 [ PANGO_STYLE_OBLIQUE, 'foreground', 'blue', NULL] );
1082
1083 gtk_text_buffer_create_tag (source_buffer, 'function', 'weight',
1084 [ PANGO_WEIGHT_BOLD, 'foreground', 'DarkGoldenrod4', NULL]);
1085
1086 gtk_window_set_default_size (GTK_WINDOW (window), 600, 400);
1087 gtk_widget_show_all (window);
1088
1089 gtk_main;
1090 end.
1091