Padre::Action - Padre Action Object

  my $action = Padre::Action->new(
    name       => 'file.save',
    label      => 'Save',
    comment    => 'Saves the current file to disk',
    icon       => '...',
    shortcut   => 'CTRL-S',
    menu_event => sub { },
  );

	group.action

	config		contains the current configuration object
	editor		the current editor object
	document	the current document object
	main		the main Wx object

	need => sub {
			my %objects = @_;
			return 0 if !defined( $objects{editor} );
			return $objects{editor}->CanUndo;
		},

package Padre::Action;

use 5.008;
use strict;
use warnings;

use Padre::Constant         ();
use Padre::Action::View     ();
use Padre::Action::File     ();
use Padre::Action::Help     ();
use Padre::Action::Edit     ();
use Padre::Action::Perl     ();
use Padre::Action::Plugins  ();
use Padre::Action::Refactor ();
use Padre::Action::Debugger ();
use Padre::Action::Run      ();
use Padre::Action::Search   ();
use Padre::Action::Window   ();
use Padre::Action::Internal ();

our $VERSION = '0.56';

# Generate faster accessors
use Class::XSAccessor {
	getters => {
		id            => 'id',
		icon          => 'icon',
		comment       => 'comment',
		name          => 'name',
		label         => 'label',
		shortcut      => 'shortcut',
		menu_event    => 'menu_event',
		toolbar_event => 'toolbar_event',
		menu_method   => 'menu_method',
		toolbar_icon  => 'toolbar',
	}
};





#####################################################################
# Functions

# This sub calls all the other files which actually create the actions
sub create {
	my $main = shift;

	Padre::Action::View->new($main);
	Padre::Action::File->new($main);
	Padre::Action::Help->new($main);
	Padre::Action::Edit->new($main);
	Padre::Action::Perl->new($main);
	Padre::Action::Plugins->new($main);
	Padre::Action::Refactor->new($main);
	Padre::Action::Debugger->new($main);
	Padre::Action::Run->new($main);
	Padre::Action::Search->new($main);
	Padre::Action::Window->new($main);
	Padre::Action::Internal->new($main);

	# This is made for usage by the developers to create a complete
	# list of all actions used in Padre. It outputs some warnings
	# while dumping, but they're ignored for now as it should never
	# run within a productional copy.
	if ( $ENV{PADRE_EXPORT_ACTIONS} ) {
		require Data::Dumper;
		require File::Spec;
		$Data::Dumper::Purity = 1;
		open my $action_export_fh, '>', File::Spec->catfile( Padre::Constant::CONFIG_DIR, 'actions.dump' );
		print $action_export_fh Data::Dumper::Dumper( Padre->ide->actions );
		close $action_export_fh;
	}

}



#####################################################################
# Constructor

sub new {
	my $class = shift;
	Carp::confess( Data::Dumper::Dumper \@_ ) if @_ % 2;
	my $self = bless {@_}, $class;
	$self->{id} ||= -1;

	if ( ( !defined( $self->{name} ) ) or ( $self->{name} eq '' ) ) {
		warn join( ',', caller ) . " tried to create an action without name";
		return;
	}

	# The menu prefix is dedicated to menus and must not be used by actions
	if ( $self->{name} =~ /^menu\./ ) {
		warn join( ',', caller ) . ' tried to create an action with name prefix menu';
		return;
	}

	if ( defined( $self->{menu_event} ) ) {

		# Menu events are handled by Padre::Action, the real events
		# should go to {event}!
		$self->add_event( $self->{menu_event} );
		$self->{menu_event} =
			eval ' return sub { ' . "Padre->ide->actions->{'" . $self->{name} . "'}->_event(\@_);" . '};';
	}

	$self->{queue_event} ||= $self->{menu_event};

	my $name     = $self->{name};
	my $shortcut = $self->{shortcut};

	my $actions = Padre->ide->actions;
	if ( $actions->{$name} ) {
		warn "Found a duplicate action '$name'\n";
	}

	if ($shortcut) {
		foreach my $n ( keys %$actions ) {
			my $a = $actions->{$n};
			next unless $a->shortcut;
			next unless $a->shortcut eq $shortcut;
			warn "Found a duplicate shortcut '$shortcut' with " . $a->name . " for '$name'\n";
			last;
		}

		my $shortcuts = Padre->ide->{shortcuts};
		if ( defined( $shortcuts->{$shortcut} ) ) {
			warn "Found a duplicate shortcut '$shortcut' with " . $shortcuts->{$shortcut}->name . " for '$name'\n";
		} else {
			$shortcuts->{$shortcut} = $self;
		}
	}

	$actions->{ $self->{name} } = $self;

	return $self;
}

# A label textual data without any strange menu characters
sub label_text {
	my $self  = shift;
	my $label = $self->label;
	$label =~ s/\&//g;
	return $label;
}

# Label for use with menu (with shortcut)
# In some cases ( http://padre.perlide.org/trac/ticket/485 )
# if a stock menu item also gets a short-cut it stops working
# hence we add the shortcut only if id == -1 indicating this was not a
# stock menu item
# The case of F12 is a special case as it uses a stock icon that does not have
# a shortcut in itself so we added one.
# (BTW Print does not have a shortcut either)
sub label_menu {
	my $self  = shift;
	my $label = $self->label;
	if ( $self->shortcut
		and ( ( $self->shortcut eq 'F12' ) or ( $self->id == -1 or Padre::Constant::WIN32() ) ) )
	{
		$label .= "\t" . $self->shortcut;
	}
	return $label;
}

# Add an event to an action:
sub add_event {
	my $self      = shift;
	my $new_event = shift;

	if ( ref($new_event) ne 'CODE' ) {
		warn 'Error: ' . join( ',', caller ) . ' tried to add "' . $new_event . '" which is no CODE-ref!';
		return 0;
	}

	if ( ref( $self->{event} ) eq 'ARRAY' ) {
		push @{ $self->{event} }, $new_event;
	} elsif ( !defined( $self->{event} ) ) {
		$self->{event} = $new_event;
	} else {
		$self->{event} = [ $self->{event}, $new_event ];
	}

	return 1;
}

sub _event {
	my $self = shift;
	my @args = @_;

	return 1 unless defined( $self->{event} );

	if ( ref( $self->{event} ) eq 'CODE' ) {
		&{ $self->{event} }(@args);
	} elsif ( ref( $self->{event} ) eq 'ARRAY' ) {
		for my $item ( @{ $self->{event} } ) {
			next if ref($item) ne 'CODE'; # TO DO: Catch error and source (Ticket #666)
			&{$item}(@args);
		}
	} else {
		warn 'Expected array or code reference but got: ' . $self->{event};
	}

	return 1;
}

#####################################################################
# Main Methods

1;

# Copyright 2008-2010 The Padre development team as listed in Padre.pm.
# LICENSE
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl 5 itself.