WxPerl::MenuMap - An object to introspect a Wx::Menu

dotReader documentation Contained in the dotReader distribution.

Index

Code Index:

NAME

Top

WxPerl::MenuMap - An object to introspect a Wx::Menu

ABOUT

Top

This package creates an object with read-only accessors for mapping the menu's items to IDs.

It is still highly experimental.

SYNOPSIS

Top

  use WxPerl::MenuMap;
  ...
  my $menu = WxPerl::MenuMap->new($menu_object);
  EVT_MENU($self, $menu->file_open, sub {$_[0]->blah($_[1])});

new

  my $menu = WxPerl::MenuMap->new($menu_object);

_init

  $self->_init;

_map_menubar

  my %map = _map_menubar($menu);

_map_menu

  my %map = _map_menu($menu);

_prep

  my $label = _prep($menulabel);

items

  my @list = $menu->items;

AUTHOR

Top

Eric Wilhelm <ewilhelm at cpan dot org>

http://scratchcomputing.com/

BUGS

Top

If you found this module on CPAN, please report any bugs or feature requests through the web interface at 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.

COPYRIGHT

Top

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

NO WARRANTY

Top

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.

LICENSE

Top

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

dotReader documentation Contained in the dotReader distribution. 
package WxPerl::MenuMap;
$VERSION = eval{require version}?version::qv($_):$_ for(0.10.1);

use warnings;
use strict;
use Carp;



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

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

  my $self = {menu => $menu};
  bless($self, $newclass);
  $self->_init;
  return($self);
} # end subroutine new definition
########################################################################


sub _init {
  my $self = shift;
  my $menu = $self->{menu};

  my $package = ref($self);

  my %map = _map_menubar($menu);
  $self->{_map} = \%map;
  foreach my $entry (keys(%map)) {
    #warn "hookup $entry";
    my $number = $map{$entry};
    no strict 'refs';
    *{$package . '::' . $entry} = eval("sub {$number}");
  }

} # end subroutine _init definition
########################################################################


sub _map_menubar {
  my ($menubar) = @_;

  my %map;
  for(my $i = 0; $i < $menubar->GetMenuCount; $i++) {
    my $menu = $menubar->GetMenu($i);
    my $label = _prep($menubar->GetLabelTop($i));
    #warn "got $label -> $menu";
    my %subm = _map_menu($menu);
    foreach my $key (keys(%subm)) {
      my $path = $label . '_' . $key;
      $map{$path} = $subm{$key};
      #warn "now $path";
    }
  }
  return(%map);
} # end subroutine _map_menubar definition
########################################################################


sub _map_menu {
  my ($menu) = @_;

  my %map;
  foreach my $item ($menu->GetMenuItems) {
    next if($item->IsSeparator);
    my $label = _prep($item->GetLabel);
    #warn "item: $item ($label)";
    $map{$label} = $item->GetId;
    my $submenu = $item->GetSubMenu or next;
    my %submap = _map_menu($submenu);
    foreach my $key (keys(%submap)) {
      my $path = $label . '_' . $key;
      $map{$path} = $submap{$key};
    }
  }
  return(%map);
} # end subroutine _map_menu definition
########################################################################


sub _prep {
  my ($label) = @_;
  $label = lc($label);
  $label =~ s/[^\w]/_/g;
  $label =~ s/^(\d)/_$1/;
  return($label);
} # end subroutine _prep definition
########################################################################


sub items {
  my $self = shift;

  return(keys(%{$self->{_map}}));
} # end subroutine items definition
########################################################################


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