#!/usr/bin/perl -w # # $Id: main.pl 2054 2008-10-05 12:49:36Z tsch $ # our $PROGDIR = $0; $PROGDIR =~ s/main.pl$//; use strict; use Carp; use Glib qw(TRUE FALSE); use Gtk2; use Gtk2::Pango; use Gtk2; use vars qw/ @testgtk_demos /; # lists of demo code descriptions. # the func is a plain string in each of these, as a sentinel value to tell # row_activated_cb that the file containing that function hasn't been # loaded yet. my @child0 = ( { title => "Editable Cells", filename => "editable_cells.pl", func => 'stub', }, { title => "List Store", filename => "list_store.pl", func => 'stub', }, { title => "Tree Store", filename => "tree_store.pl", func => 'stub', }, ); my @child1 = ( { title => "Hypertext", filename => "hypertext.pl", func => 'stub', }, { title => "Multiple Views", filename => "textview.pl", func => 'stub', }, ); @testgtk_demos = ( { title => "Application main window", filename => "appwindow.pl", func => 'stub', }, { title => "Button Boxes", filename => "button_box.pl", func => 'stub', }, { title => "Change Display", filename => "changedisplay.pl", func => 'stub', }, { title => "Color Selector", filename => "colorsel.pl", func => 'stub', }, { title => "Dialog and Message Boxes", filename => "dialog.pl", func => 'stub', }, { title => "Drawing Area", filename => "drawingarea.pl", func => 'stub', }, { title => "Images", filename => "images.pl", func => 'stub', }, { title => "Item Factory", filename => "item_factory.pl", func => 'stub', }, { title => "Menus", filename => "menus.pl", func => 'stub', }, { title => "Paned Widgets", filename => "panes.pl", func => 'stub', }, { title => "Pixbufs", filename => "pixbufs.pl", func => 'stub', }, { title => "Size Groups", filename => "sizegroup.pl", func => 'stub', }, { title => "Stock Item and Icon Browser", filename => "stock_browser.pl", func => 'stub', }, { title => "Text Widget", children => \@child1 }, { title => "Tree View", children => \@child0 }, ); push @testgtk_demos, { title => "Entry Completion", filename => "entry_completion.pl", func => 'stub', }, { title => "UI Manager", filename => "ui_manager.pl", func => 'stub', } if Gtk2->CHECK_VERSION (2, 4, 0); push @testgtk_demos, { title => "Rotated Text", filename => "rotated_text.pl", func => 'stub', }, if Gtk2->CHECK_VERSION (2, 6, 0); # some globals. my $info_buffer; my $source_buffer; my $current_file; # clean names for column numbers. use constant TITLE_COLUMN => 0; use constant FILENAME_COLUMN => 1; use constant FUNC_COLUMN => 2; use constant ITALIC_COLUMN => 3; use constant NUM_COLUMNS => 4; #/** # * demo_find_file: # * @base: base filename # * @err: location to store error, or %NULL. # * # * Looks for @base first in the current directory, then in the # * location GTK+ where it will be installed on make install, # * returns the first file found. # * # * Return value: the filename, if found or %NULL # **/ sub demo_find_file { my $base = shift; return $base if -e $base; my $filename = $PROGDIR.$base; croak "Cannot find demo data file $base ($filename)\n" unless -e $filename; return $filename; } sub window_closed_cb { my ($window, $cbdata) = @_; my $iter = $cbdata->{model}->get_iter ($cbdata->{path}); my ($italic) = $cbdata->{model}->get ($iter, ITALIC_COLUMN); $cbdata->{model}->set ($iter, ITALIC_COLUMN, !$italic) if $italic; } # # Stupid syntax highlighting. # # No regex was used in the making of this highlighting. # It should only work for simple cases. This is good, as # that's all we should have in the demos. # # This code should not be used elsewhere, except perhaps as an example of how # to iterate through a text buffer. # use constant STATE_NORMAL => 0; use constant STATE_IN_COMMENT => 1; =out static gchar *tokens[] = { "/*", "\"", NULL }; static gchar *types[] = { "static", "const ", "void", "gint", "int ", "char ", "gchar ", "gfloat", "float", "gint8", "gint16", "gint32", "guint", "guint8", "guint16", "guint32", "guchar", "glong", "gboolean" , "gshort", "gushort", "gulong", "gdouble", "gldouble", "gpointer", "NULL", "GList", "GSList", "FALSE", "TRUE", "FILE ", "GtkObject ", "GtkColorSelection ", "GtkWidget ", "GtkButton ", "GdkColor ", "GdkRectangle ", "GdkEventExpose ", "GdkGC ", "GdkPixbufLoader ", "GdkPixbuf ", "GError", "size_t", NULL }; static gchar *control[] = { " if ", " while ", " else", " do ", " for ", "?", ":", "return ", "goto ", NULL }; void parse_chars (gchar *text, gchar **end_ptr, gint *state, gchar **tag, gboolean start) { gint i; gchar *next_token; /* Handle comments first */ if (*state == STATE_IN_COMMENT) { *end_ptr = strstr (text, "*/"); if (*end_ptr) { *end_ptr += 2; *state = STATE_NORMAL; *tag = "comment"; } return; } *tag = NULL; *end_ptr = NULL; /* check for comment */ if (!strncmp (text, "/*", 2)) { *end_ptr = strstr (text, "*/"); if (*end_ptr) *end_ptr += 2; else *state = STATE_IN_COMMENT; *tag = "comment"; return; } /* check for preprocessor defines */ if (*text == '#' && start) { *end_ptr = NULL; *tag = "preprocessor"; return; } /* functions */ if (start && * text != '\t' && *text != ' ' && *text != '{' && *text != '}') { if (strstr (text, "(")) { *end_ptr = strstr (text, "("); *tag = "function"; return; } } /* check for types */ for (i = 0; types[i] != NULL; i++) if (!strncmp (text, types[i], strlen (types[i]))) { *end_ptr = text + strlen (types[i]); *tag = "type"; return; } /* check for control */ for (i = 0; control[i] != NULL; i++) if (!strncmp (text, control[i], strlen (control[i]))) { *end_ptr = text + strlen (control[i]); *tag = "control"; return; } /* check for string */ if (text[0] == '"') { gint maybe_escape = FALSE; *end_ptr = text + 1; *tag = "string"; while (**end_ptr != '\000') { if (**end_ptr == '\"' && !maybe_escape) { *end_ptr += 1; return; } if (**end_ptr == '\\') maybe_escape = TRUE; else maybe_escape = FALSE; *end_ptr += 1; } return; } /* not at the start of a tag. Find the next one. */ for (i = 0; tokens[i] != NULL; i++) { next_token = strstr (text, tokens[i]); if (next_token) { if (*end_ptr) *end_ptr = (*end_ptr<next_token)?*end_ptr:next_token; else *end_ptr = next_token; } } for (i = 0; types[i] != NULL; i++) { next_token = strstr (text, types[i]); if (next_token) { if (*end_ptr) *end_ptr = (*end_ptr<next_token)?*end_ptr:next_token; else *end_ptr = next_token; } } for (i = 0; control[i] != NULL; i++) { next_token = strstr (text, control[i]); if (next_token) { if (*end_ptr) *end_ptr = (*end_ptr<next_token)?*end_ptr:next_token; else *end_ptr = next_token; } } } =cut # # While not as cool as c-mode, this will do as a quick attempt at highlighting # sub fontify { my $text; my ($end_ptr, $tag); my $state = STATE_NORMAL; my $start_iter = $source_buffer->get_iter_at_offset (0); ## my $next_iter = $start_iter->copy; my $next_iter = $start_iter; while ($next_iter = $next_iter->forward_line) { my $start = TRUE; my $start_ptr = $text = $start_iter->get_text ($next_iter); do { ($end_ptr, $tag) = parse_chars ($start_ptr, $state, $start); my $tmp_iter; $start = FALSE; if ($end_ptr) { ## $tmp_iter = $start_iter->copy; $tmp_iter = $start_iter; $tmp_iter->forward_chars ($end_ptr - $start_ptr); } else { ## $tmp_iter = $next_iter->copy; $tmp_iter = $next_iter; } if ($tag) { $source_buffer->apply_tag_by_name ($tag, $start_iter, $tmp_iter); } $start_iter = $tmp_iter; $start_ptr = $end_ptr; } while ($end_ptr); ## $start_iter = $next_iter->copy; $start_iter = $next_iter; } } sub load_file { my $filename = shift; my $state = 0; my $in_para = 0; return if defined $current_file and $current_file eq $filename; $current_file = $filename; $info_buffer->delete ($info_buffer->get_bounds); $source_buffer->delete ($source_buffer->get_bounds); my $full_filename; eval { $full_filename = demo_find_file ($filename); }; if ($@) { warn $@; } local *IN; open IN, $full_filename or warn("cannot open $full_filename: $!\n"), return; my $start = $info_buffer->get_iter_at_offset (0); while (<IN>) { if ($state == 0) { # Reading title if (/^#!/) { # skip the interpreter line... } elsif (/^\s*#?\s*$/) { # skip blank lines preceding the title } else { # this must be the title! s/^#\s*//; s/\s*$//; ## my $end = $start->copy; my $end = $start; $info_buffer->insert ($end, $_); ## $start = $end; ###print "$start $end\n"; # gtk_text_iter_backward_chars (&start, len_chars); $start = $info_buffer->get_iter_at_offset (0); $info_buffer->apply_tag_by_name ("title", $start, $end); # $start = $end; $state++; } } elsif ($state == 1) { # Reading body of info section if (/^\s*$/) { # completely blank line ends the info section. $state++; } else { # strip leading junk s/^#?\s+//; # strip trailing junk s/\s+$//; if (length($_) > 0) { $info_buffer->insert ($start, " ") if $in_para; $info_buffer->insert ($start, $_); $in_para = 1; } else { $info_buffer->insert ($start, "\n"); $in_para = 0; } } } elsif ($state == 2) { # Skipping blank lines s/^\s+//; if (length ($_)) { $state++; $start = $source_buffer->get_iter_at_offset (0); $source_buffer->insert ($start, $_); } } elsif ($state == 3) { # Reading program body $source_buffer->insert ($start, $_); } } # fontify (); } sub row_activated_cb { my ($tree_view, $path, $column) = @_; my $model = $tree_view->get_model; my $iter = $model->get_iter ($path); my ($filename, $func, $italic) = $model->get ($iter, FILENAME_COLUMN, FUNC_COLUMN, ITALIC_COLUMN); # this is rather a bit of a departure from the C version. # in the C version, the various demos are in separate modules that # get compiled into the program. perl doesn't work that way. so, we # have the code in external files that define a package with the same # name as the file (sans the .pl). if the demo has never been run, # the func column will contain a string; when we see that, we'll # require the file, set the func column to point to the "do" method # within that file's declared package, and then retrieve that function # pointer again. it's a kind of hackish lazy loading mechanism. # don't try this at home. if ('CODE' ne ref $func) { my $pkg = $filename; $filename = demo_find_file($filename); require $filename; $pkg =~ s/\.pl$//; eval '$model->set ($iter, FUNC_COLUMN, \&'.$pkg.'::do);'; ($func) = $model->get ($iter, FUNC_COLUMN); } if ($func) { # set this row italic to show that the demo is running... $model->set ($iter, ITALIC_COLUMN, !$italic); my $window = $func->($tree_view->get_toplevel); if ($window) { # unset the italics when the window closes. $window->signal_connect (destroy => \&window_closed_cb, { model => $model, path => $path->copy }); } } } sub selection_cb { my ($selection, $model) = @_; my $iter = $selection->get_selected; return unless defined $iter; my ($name) = $model->get ($iter, FILENAME_COLUMN); load_file ($name) if $name; } sub create_text { my ($buffer_ref, $is_source) = @_; my $scrolled_window = Gtk2::ScrolledWindow->new; $scrolled_window->set_policy ('automatic', 'automatic'); $scrolled_window->set_shadow_type ('in'); my $text_view = Gtk2::TextView->new; $$buffer_ref = Gtk2::TextBuffer->new (undef); $text_view->set_buffer ($$buffer_ref); $text_view->set_editable (FALSE); $text_view->set_cursor_visible (FALSE); $scrolled_window->add ($text_view); if ($is_source) { my $font_desc = Gtk2::Pango::FontDescription->from_string ("Courier 12"); $text_view->modify_font ($font_desc); $text_view->set_wrap_mode ('none'); } else { # Make it a bit nicer for text. $text_view->set_wrap_mode ('word'); $text_view->set_pixels_above_lines (2); $text_view->set_pixels_below_lines (2); } return $scrolled_window; } sub create_tree { my $model = Gtk2::TreeStore->new ('Glib::String', 'Glib::String', 'Glib::Scalar', 'Glib::Boolean'); my $tree_view = Gtk2::TreeView->new; $tree_view->set_model ($model); my $selection = $tree_view->get_selection; $selection->set_mode ('browse'); $tree_view->set_size_request (200, -1); # # this code only supports 1 level of children. If we # want more we probably have to use a recursing function. # foreach my $d (@testgtk_demos) { my $iter = $model->append (undef); $model->set ($iter, TITLE_COLUMN, $d->{title}, FILENAME_COLUMN, $d->{filename} || '', FUNC_COLUMN, $d->{func} || '', ITALIC_COLUMN, FALSE); next unless $d->{children}; foreach my $child (@{ $d->{children} }) { my $child_iter = $model->append ($iter); $model->set ($child_iter, TITLE_COLUMN, $child->{title}, FILENAME_COLUMN, $child->{filename}, FUNC_COLUMN, $child->{func}, ITALIC_COLUMN, FALSE); } } my $cell = Gtk2::CellRendererText->new; $cell->set ('style' => 'italic'); my $column = Gtk2::TreeViewColumn->new_with_attributes ("Widget (double click for demo)", $cell, 'text' => TITLE_COLUMN, 'style_set' => ITALIC_COLUMN); $tree_view->append_column ($column); $selection->signal_connect (changed => \&selection_cb, $model); $tree_view->signal_connect (row_activated => \&row_activated_cb, $model); $tree_view->expand_all; return $tree_view; } sub setup_default_icon { my $pixbuf; eval { $pixbuf = Gtk2::Gdk::Pixbuf->new_from_file (demo_find_file ("gtk-logo-rgb.gif")); }; if ($@) { my $dialog = Gtk2::MessageDialog->new (undef, [], 'error', 'close', "Failed to read icon file: $@"); $dialog->signal_connect (response => sub { $_[0]->destroy; 1 }); } if ($pixbuf) { # The gtk-logo-rgb icon has a white background, make it transparent my $transparent = $pixbuf->add_alpha (TRUE, 0xff, 0xff, 0xff); # only one item on the parameter list, but the parameter list is a list Gtk2::Window->set_default_icon_list ($transparent); } } Gtk2->init; setup_default_icon (); my $window = Gtk2::Window->new; $window->set_title ("Gtk2-Perl Code Demos"); $window->signal_connect (destroy => sub { Gtk2->main_quit; 1 }); my $hbox = Gtk2::HBox->new (FALSE, 0); $window->add ($hbox); my $tree = create_tree (); $hbox->pack_start ($tree, FALSE, FALSE, 0); my $notebook = Gtk2::Notebook->new; $hbox->pack_start ($notebook, TRUE, TRUE, 0); $notebook->append_page (create_text (\$info_buffer, FALSE), Gtk2::Label->new_with_mnemonic ("_Info")); $notebook->append_page (create_text (\$source_buffer, TRUE), Gtk2::Label->new_with_mnemonic ("_Source")); my $tag; $tag = $info_buffer->create_tag ("title", font => "Sans 18"); $tag = $source_buffer->create_tag ("comment", foreground => "red"); $tag = $source_buffer->create_tag ("type", foreground => "ForestGreen"); $tag = $source_buffer->create_tag ("string", foreground => "RosyBrown", weight => PANGO_WEIGHT_BOLD); $tag = $source_buffer->create_tag ("control", "foreground", "purple"); $tag = $source_buffer->create_tag ('preprocessor', style => 'oblique', foreground => 'burlywood4'); $tag = $source_buffer->create_tag ('function', weight => PANGO_WEIGHT_BOLD, foreground => 'DarkGoldenrod4'); $window->set_default_size (600, 400); $window->show_all; # this happens anyway, when the list selects the first item on show # load_file ($testgtk_demos[0]{filename}); Gtk2->main; __END__ Copyright (C) 2003 by the gtk2-perl team (see the file AUTHORS for the full list) This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307 USA.