The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl -w
#
# Application main window
#
# Demonstrates a typical application window, with menubar, toolbar, statusbar.
#

package appwindow;

use Glib ':constants';
use Gtk2;
#include "demo-common.h"

my $window = undef;


sub menuitem_cb {
  my ($callback_data, $callback_action, $widget) = @_;
  
  my $dialog = Gtk2::MessageDialog->new ($callback_data,
                                         'destroy-with-parent',
                                         'info',
                                         'close',
                                         sprintf "You selected or toggled the menu item: \"%s\"",
                                    Gtk2::ItemFactory->path_from_widget ($widget));

  # Close dialog on user response
  $dialog->signal_connect (response => sub { $dialog->destroy; 1 });
  
  $dialog->show;
}


my @menu_items = (
  [ "/_File",            undef,        undef,          0, "<Branch>" ],
  [ "/File/_New",        "<control>N", \&menuitem_cb,  0, "<StockItem>", 'gtk-new' ],
  [ "/File/_Open",       "<control>O", \&menuitem_cb,  0, "<StockItem>", 'gtk-open' ],
  [ "/File/_Save",       "<control>S", \&menuitem_cb,  0, "<StockItem>", 'gtk-save' ],
  [ "/File/Save _As...", undef,        \&menuitem_cb,  0, "<StockItem>", 'gtk-save' ],
  [ "/File/sep1",        undef,        \&menuitem_cb,  0, "<Separator>" ],
  [ "/File/_Quit",       "<control>Q", \&menuitem_cb,  0, "<StockItem>", 'gtk-quit' ],

  [ "/_Preferences",                  undef, undef,         0, "<Branch>" ],
  [ "/_Preferences/_Color",           undef, undef,         0, "<Branch>" ],
  [ "/_Preferences/Color/_Red",       undef, \&menuitem_cb, 0, "<RadioItem>" ],
  [ "/_Preferences/Color/_Green",     undef, \&menuitem_cb, 0, "/Preferences/Color/Red" ],
  [ "/_Preferences/Color/_Blue",      undef, \&menuitem_cb, 0, "/Preferences/Color/Red" ],
  [ "/_Preferences/_Shape",           undef, undef,         0, "<Branch>" ],
  [ "/_Preferences/Shape/_Square",    undef, \&menuitem_cb, 0, "<RadioItem>" ],
  [ "/_Preferences/Shape/_Rectangle", undef, \&menuitem_cb, 0, "/Preferences/Shape/Square" ],
  [ "/_Preferences/Shape/_Oval",      undef, \&menuitem_cb, 0, "/Preferences/Shape/Rectangle" ],

  # If you wanted this to be right justified you would use "<LastBranch>", not "<Branch>".
  # Right justified help menu items are generally considered a bad idea now days.
  [ "/_Help",       undef, undef,         0, "<Branch>" ],
  [ "/Help/_About", undef, \&menuitem_cb, 0 ],
);


sub toolbar_cb {
  my ($button, $data) = @_;
  
  my $dialog = Gtk2::MessageDialog->new ($data, 'destroy-with-parent',
                                         'info', 'close',
                                         "You selected a toolbar button");

  # Close dialog on user response
  $dialog->signal_connect (response => sub { $_[0]->destroy; 1 });
  
  $dialog->show;
}

#
# This function registers our custom toolbar icons, so they can be themed.
#
# It's totally optional to do this, you could just manually insert icons
# and have them not be themeable, especially if you never expect people
# to theme your app.
#
my $registered = FALSE;
sub register_stock_icons {
  if (!$registered) {
      my @items = (
        #[ "demo-gtk-logo", "_GTK!", 0, 0, undef ]
        {
           stock_id => "demo-gtk-logo",
           label => "_GTK!",
        },
      );
      
      $registered = TRUE;

      # Register our stock items
      Gtk2::Stock->add (@items);
      
      # Add our custom icon factory to the list of defaults
      my $factory = Gtk2::IconFactory->new;
      $factory->add_default;

      #
      # demo_find_file() looks in the the current directory first,
      # so you can run gtk-demo without installing GTK, then looks
      # in the location where the file is installed.
      #
      my $pixbuf = undef;
###      my $filename = demo_find_file ("gtk-logo-rgb.gif", undef);
      my $filename = "gtk-logo-rgb.gif";
      if ($filename) {
          eval {
             $pixbuf = Gtk2::Gdk::Pixbuf->new_from_file (
		     main::demo_find_file ($filename));

             # The gtk-logo-rgb icon has a white background, make it transparent
             my $transparent = $pixbuf->add_alpha (TRUE, 0xff, 0xff, 0xff);
          
             my $icon_set = Gtk2::IconSet->new_from_pixbuf ($transparent);
             $factory->add ("demo-gtk-logo", $icon_set);
          };
          warn "failed to load GTK logo for toolbar"
              if $@;
      }
      # $factory goes out of scope here, but GTK will hold a reference on it.
  }
}

sub update_statusbar {
  my ($buffer, $statusbar) = @_;

  $statusbar->pop (0); # clear any previous message, underflow is allowed

  my $count = $buffer->get_char_count;

  my $iter = $buffer->get_iter_at_mark ($buffer->get_insert);

  my $row = $iter->get_line;
  my $col = $iter->get_line_offset;

  $statusbar->push (0, "Cursor at row $row column $col - $count chars in document");
}

sub mark_set_callback {
  my ($buffer, $new_location, $mark, $data) = @_;
  update_statusbar ($buffer, $data);
}


sub do {  
  if (!$window) {
      register_stock_icons ();
     
      # 
      # Create the toplevel window
      #
      
      $window = Gtk2::Window->new;
      $window->set_title ("Application Window");

      # NULL window variable when window is closed
      $window->signal_connect (destroy => sub { $window = undef; 1 });

      my $table = Gtk2::Table->new (1, 4, FALSE);
      
      $window->add ($table);
      
      #
      # Create the menubar
      #
      
      my $accel_group = Gtk2::AccelGroup->new;
      $window->add_accel_group ($accel_group);
      
      my $item_factory = Gtk2::ItemFactory->new ("Gtk2::MenuBar", "<main>", 
                                                 $accel_group);

      # Set up item factory to go away with the window
      $window->{'<main>'} = $item_factory;

      # create menu items
      $item_factory->create_items ($window, @menu_items);

      $table->attach ($item_factory->get_widget ("<main>"),
                      # X direction         Y direction
                      0, 1,                 0, 1,
                      [qw/expand fill/],    [],
                      0,                    0);

      #
      # Create the toolbar
      #
      my $toolbar = Gtk2::Toolbar->new;

      $toolbar->insert_stock ('gtk-open',
                              "This is a demo button with an 'open' icon",
                              undef,
                              \&toolbar_cb,
                              $window, # user data for callback
                              -1);  # -1 means "append"

      $toolbar->insert_stock ('gtk-quit',
                              "This is a demo button with a 'quit' icon",
                              undef,
                              \&toolbar_cb,
                              $window, # user data for callback
                              -1);  # -1 means "append"

      $toolbar->append_space;

      $toolbar->insert_stock ("demo-gtk-logo",
                              "This is a demo button with a 'gtk' icon",
                              undef,
                              \&toolbar_cb,
                              $window, # user data for callback
                              -1);  # -1 means "append"

      $table->attach ($toolbar,
                      # X direction      Y direction
                      0, 1,              1, 2,
                      [qw/expand fill/], [],
                      0,                 0);

      #
      # Create document
      #

      my $sw = Gtk2::ScrolledWindow->new;

      $sw->set_policy ('automatic', 'automatic');

      $sw->set_shadow_type ('in');
      
      $table->attach ($sw,
                      #  X direction     Y direction
                      0, 1,              2, 3,
                      [qw/expand fill/], [qw/expand fill/],
                      0,                 0);

      $window->set_default_size (200, 200);
      
      my $contents = Gtk2::TextView->new;

      $sw->add ($contents);

      # Create statusbar

      my $statusbar = Gtk2::Statusbar->new;
      $table->attach ($statusbar,
                      # X direction      Y direction
                      0, 1,              3, 4,
                      [qw/expand fill/], [],
                      0,                 0);

      # Show text widget info in the statusbar
      my $buffer = $contents->get_buffer;
      
      $buffer->signal_connect (changed => \&update_statusbar, $statusbar);

      # mark-set means cursor moved
      $buffer->signal_connect (mark_set => \&mark_set_callback, $statusbar);
      
      update_statusbar ($buffer, $statusbar);
  }

  if (!$window->visible) {
      $window->show_all;
  } else {    
      $window->destroy;
      $window = undef;
  }

  return $window;
}


1;
__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.