package WxPerl::MenuMaker;

use warnings;
use strict;
use Carp;

our $VERSION = '0.01';

use Wx ();
use Wx::Event ();

=head1 NAME

WxPerl::MenuMaker - create and manage linked menus and toolbars

=head1 SYNOPSIS

This is not a wxMenu, only a way to hold and manage named references to
the menu items and toolbar items.

  my $mm = WxPerl::MenuMaker->new(
    handler => $self,
    nomethod => sub {warn "$_[1] cannot '$_[0]()'"},
  );

  $mm->create_menubar(\@menu);
  # the toolbar takes a few more parameters
  $mm->create_toolbar(\@toolbar,
    parent => $frame, # all you really need
    id => -1,
    position => wxDefaultPosition,
    size => wxDefaultSize,
    style => wxTB_HORIZONTAL|wxTB_FLAT|wxTB_DOCKABLE,
    bitmap_size => [32, 32],
  );

  # and you can get them back
  my $menu = $mm->menubar;
  my $menu_item = $mm->menu_items->file_open;
  my $toolbar = $mm->toolbar;
  my $toolbar_item = $mm->toolbar_items->that_button;

  # and
  my $associate = $mm->associated_menu->that_button;

=cut

=head1 Constructor

=head2 new

  my $mm = WxPerl::MenuMaker->new(
    handler => $self,
    nomethod => sub {warn "$_[1] cannot '$_[0]()'"},
  );

=cut

sub new {
  my $class = shift;
  (@_ % 2) and croak('odd number of elements in argument list');
  my (%args) = @_;
  ref($class) and croak("not an object method");

  my $self = {%args};
  # create the classes
  my $class_base = "$self";
  $class_base =~ s/HASH\(([^\)]*)\)/${class}::$1/ or
    croak("cannot transform $self into a package");
  my $newclass_isa = do { no strict 'refs'; \@{"${class_base}::ISA"}; };
  push(@$newclass_isa, $class); # You're one of us now...

  my @classes = qw(
    menu_items
    toolbar_items
    toolbar_meta
    associated_tool
    associated_menu
    );
  foreach my $attrib (@classes) {
    my $new_class = $class_base . '::' . $attrib;
    my $obj = {};
    bless($obj, $new_class);
    $class->_mk_accessor($class_base, $attrib, $obj);
  }

  bless($self, $class_base);
  return($self);
} # end subroutine new definition
########################################################################
sub handler {$_[0]->{handler}};
sub nomethod {$_[0]->{nomethod}};

=head2 create_menubar

Should typically be called before create_toolbar().

  my @menu = (
    {
      name  => 'file',
      menu  => [...], # see create_menu()
      label => '&File',
    }
  );
  $mm->create_menubar(\@menu);

In the above example, the submenu [...] will have its entries prefixed
by C<file_>.  Thus, you will be able to access the C<open> submenu item
via C<$mm-E<gt>menu_items-E<gt>file_open>.

=cut

sub create_menubar {
  my $self = shift;
  my $mmap = shift(@_) or croak('requires menu argument');
  (ref($mmap || '') eq 'ARRAY') or croak("requires an array reference");

  my $menubar = Wx::MenuBar->new();
  $self->_mk_accessor($self, 'menubar', $menubar);
  # now walk through that
  for(my $i = 0; $i < @$mmap; $i++) {
    my $item = $mmap->[$i];
    my $name = $self->_name_check($item->{name}) or
      croak("menubar item $i has no name");
    my $submenu = $item->{menu} or croak("item $i has no submenu");
    my $menu = $self->create_menu($submenu, prefix => $name . '_');

    # XXX not sure I like this bit of storing toplevel (menubar) entries
    # in with all of the menu items, but if file_open is in file, it
    # sort of makes sense
    $self->_mk_accessor($self->menu_items, $name, $menu);
    $menubar->Append($menu, $item->{label});
  }
  if(my $handler = $self->handler) {
    $handler->SetMenuBar($menubar);
  }
  return($menubar);
} # end subroutine create_menubar definition
########################################################################

=head2 create_menu

This is called for you by create_menubar().

Using this for standalone menus is untested.

  my @menu = (
    {
      name        => 'open',
      action      => 'file_open',
      label       => '&Open
    },
    {
      separator   => 1
    },
    {
      auto_action => 1,
      name        => 'quit',
      label       => 'Quit'
    }
  );
  my $menu = $mm->create_menu(\@menu, prefix => 'file_');

The hash reference items in the array are treated as follows:

=over

=item separator

Set the C<separator> property to true to get a separator.

=item action

If C<action> is defined, the event will be connected to a
menu_C<action>() method.

=item auto_action

If C<auto_action> is not present and false, your menu events will be
connected to 'menu_' . $name (where $name starts with the prefix.)

=back

In the above example, the resultant events are menu_file_open() and
menu_file_quit().

=cut

sub create_menu {
  my $self = shift;
  my $mmap = shift(@_) or croak('requires menu argument');
  (ref($mmap || '') eq 'ARRAY') or croak("requires an array reference");
  (@_ % 2) and croak('odd number of elements in argument list');
  my (%args) = @_;

  my $menu = Wx::Menu->new();
  # now walk through that
  for(my $i = 0; $i < @$mmap; $i++) {
    my $item = $mmap->[$i];
    if($item->{separator}) {
      $menu->AppendSeparator;
      next;
    }
    my $name = $self->_name_check($item->{name}) or
      croak("menu item $i has no name");
    $name = $args{prefix} . $name if($args{prefix});
    my $menu_item;
    if(my $array = $item->{menu}) {
      #warn "create submenu for $name\n";
      my $submenu = $self->create_menu($array , prefix => $name . '_');
      #warn "got submenu $submenu $item->{label}";
      $menu_item = $menu->Append(
        Wx::NewId(), $item->{label}, $submenu, ''
      );
    }
    else {
      $menu_item = $menu->Append(Wx::NewId(), $item->{label}, '');
      $self->_mk_event($item, $name, $menu_item);
    }
    $self->_mk_accessor($self->menu_items, $name, $menu_item);
  }
  return($menu);
} # end subroutine create_menu definition
########################################################################

=head2 _name_check

  $name = $self->_name_check($item->{name});

=cut

sub _name_check {
  my $self = shift;
  my ($name) = @_;
  $name or return;
  ($name =~ m/^\w+$/ and $name !~ m/^\d/) or
    croak("'$name' is invalid");
  return($name);
} # end subroutine _name_check definition
########################################################################

=head2 create_toolbar

  my @toolbar = (
    {
      tooltip     => 'File Manager',
      icon        => 'file-manager.png',
      auto_action => 0,
      name        => 'file_manager'
    },
    {
      tooltip     => 'Notes',
      icon        => 'tb_button_notes.png',
      name        => 'notes'
    },
    {
      separator => '1'
    },
    {
      tooltip     => 'Open File',
      icon        => 'kedit.png',
      associate   => 'file_open',
      name        => 'file_open'
    },
    {
      tooltip     => 'Browse',
      icon        => 'tb_button_browse.png',
      action      => 'do_something',
      name        => 'browse'
    },
    {
      tooltip     => 'Foo',
      icon        => 'tb_button_foo.png',
      action      => sub {warn "this is foo"},
      name        => 'foo'
    }
  );

  $mm->create_toolbar(\@toolbar,
    parent      => $frame, # all you really need
    id          => -1,
    position    => wxDefaultPosition,
    size        => wxDefaultSize,
    style       => wxTB_HORIZONTAL|wxTB_FLAT|wxTB_DOCKABLE,
    bitmap_size => [32, 32],
  );

If you set a handler in the constructor, you will not need to pass the
parent argument to this method.

The toolbar items are connected much like in create_menu(), except that
the default method is menu_tb_C<name>().

The C<associate> property will cause the tool to be associated to that
menu entry.  This means they will have the same ID (and thus the same
events.)

=cut

sub create_toolbar {
  my $self = shift;
  my $tb = shift(@_) or croak('requires menu argument');
  (ref($tb || '') eq 'ARRAY') or croak("requires an array reference");
  (@_ % 2) and croak('odd number of elements in argument list');
  my (%args) = @_;
  my $parent = $args{parent} || $self->{handler};
  $parent or croak('must have parent argument');
  $self->{handler} ||= $parent;
  my $size = $args{size} || [32, 32];

  my $toolbar = Wx::ToolBar->new($parent,
    -1,
    exists($args{position}) ? $args{position} : Wx::wxDefaultPosition(),
    exists($args{size}) ? $args{size} : Wx::wxDefaultSize(),
    exists($args{style}) ? $args{style} :
      Wx::wxTB_HORIZONTAL()|Wx::wxTB_FLAT()
  );

  # create the closure for it
  $self->_mk_accessor($self, 'toolbar', $toolbar);

  # run down the list
  for(my $i = 0; $i < @$tb; $i++) {
    my $item = $tb->[$i];
    $self->_add_toolbar_item(%$item, _num => $i);
  }

	$parent->SetToolBar($toolbar);
  $toolbar->SetToolBitmapSize(Wx::wxSIZE(@$size));
  $toolbar->Realize();
  return($toolbar);
} # end subroutine create_toolbar definition
########################################################################

=head2 append_toolbar

  $mm->append_toolbar(%args);

=cut

sub append_toolbar {
  my $self = shift;
  (@_ % 2) and croak('odd number of elements in argument list');
  my (%args) = @_;

  $self->_add_toolbar_item(separator => 1);
  my $item = $self->_add_toolbar_item(%args);
  $self->toolbar->Realize;
  return($item);
} # end subroutine append_toolbar definition
########################################################################

=head2 _add_toolbar_item

  my $tool = $self->_add_toolbar_item(%args);

=cut

sub _add_toolbar_item {
  my $self = shift;
  (@_ % 2) and croak('odd number of elements in argument list');
  my (%item) = @_;

  my $toolbar = $self->toolbar;

  if($item{separator}) {
    return($toolbar->AddSeparator());
  }

  defined(my $name = $item{name}) or croak("item ",
    (exists($item{_num}) ? "($item{_num})" : ''), " must have a name");
  #warn "adding $name with $item{icon}";
  my $id = -1;
  my $associate = $item{associate};
  if($associate) {
    my $assoc = $self->menu_items->$associate;
    $id = $assoc->GetId;
  }

  (-e $item{icon}) or
    croak("missing icon '$item{icon}' for toolbar item '$name'");
  my $tool = $toolbar->AddTool($id, $name,
    Wx::Bitmap->new($item{icon}, Wx::wxBITMAP_TYPE_ANY()),
    (defined($item{alt_icon}) ?
      Wx::Bitmap->new($item{alt_icon}, Wx::wxBITMAP_TYPE_ANY()) :
      Wx::wxNullBitmap()
    ),
    Wx::wxITEM_NORMAL(), # TODO style
    $item{tooltip},
    (defined($item{longhelp}) ? $item{longhelp} : ''),
  );
  $self->_mk_accessor($self->toolbar_items, $name, $tool);

  if($associate) { # association *by name only*
    $self->_mk_accessor($self->associated_menu, $name, $associate);
    $self->_mk_accessor($self->associated_tool, $associate, $name);
  }
  else { # set the event
    $self->_mk_event(\%item, 'tb_' . $name, $tool->GetId);
  }
  return($tool);
} # end subroutine _add_toolbar_item definition
########################################################################

=head2 _mk_accessor

  $class->_mk_accessor($package, $method, $value);

=cut

sub _mk_accessor {
  my $self = shift;
  my ($package, $method, $value) = @_;
  my $class = ref($package) || $package;
  no strict 'refs';
  *{$class . '::' . $method} = sub {$value};
} # end subroutine _mk_accessor definition
########################################################################

=head2 _mk_event

  $self->_mk_event($item, $name, $menu_item);

=cut

sub _mk_event {
  my $self = shift;
  my ($item, $name, $menu) = @_;

  my $dbg = 0;

  my $handler = $self->handler or return;
  my $auto = (exists($item->{auto_action}) ? $item->{auto_action} : 1);
  $auto = 0 if(defined($item->{action}));
  if(my $action = ($auto ? $name : $item->{action})) {
    my $subref;
    if(ref($action) || '' eq 'CODE') {
      $subref = $action;
    }
    else {
      $action = 'menu_' . $action;
      $dbg and warn "connect $action to $name for $menu";
      unless($handler->can($action)) {
        $dbg and warn "cannot";
        if(my $sub = $self->nomethod) {
          $dbg and warn "nomethod";
          Wx::Event::EVT_MENU(
            $handler, $menu, sub {$sub->($action, @_)}
          );
        }
        return;
      }
      $subref = sub {$_[0]->$action($_[1])};
      $dbg and warn "can";
    }
    Wx::Event::EVT_MENU($handler, $menu, $subref);
  }
  return;
} # end subroutine _mk_event definition
########################################################################

=head1 AUTHOR

Eric Wilhelm <ewilhelm at cpan dot org>

http://scratchcomputing.com/

=head1 BUGS

If you found this module on CPAN, please report any bugs or feature
requests through the web interface at L<http://rt.cpan.org>.  I will be
notified, and then you'll automatically be notified of progress on your
bug as I make changes.

If you pulled this development version from my /svn/, please contact me
directly.

=head1 COPYRIGHT

Copyright (C) 2006 Eric L. Wilhelm, All Rights Reserved.

=head1 NO WARRANTY

Absolutely, positively NO WARRANTY, neither express or implied, is
offered with this software.  You use this software at your own risk.  In
case of loss, no person or entity owes you anything whatsoever.  You
have been warned.

=head1 LICENSE

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

# vi:ts=2:sw=2:et:sta
1;
