1. Herbert Breunung
  2. Kephra

Source

Kephra / lib / Kephra / API / Command.pm

use strict;
use warnings;
use Kephra::API;

package Kephra::API::Command;                             # callable by the user

my %list;     # by ID
#my %keyproxy;# by keycode
my %switch   = ( 'name' => {}, 'package' => {} ); #switchvar vor cmd definitions
my %switchvar; #switchvar vor cmd definitions
my $done_init = 0;

sub      _raw_list { \%list }
sub sub_exists     { no strict 'refs'; *{ $_[0] }{CODE} if $_[0] }
sub package_exists { no strict 'refs'; %{ $_[0] . '::' } if $_[0] }
sub calling_module { ( caller(1) )[0] }


# can only be called once, by Kephra::API and before the init
sub switch_variables {
	my ($var_def) = shift;
	my $api = 'Kephra::API';
	my $caller = calling_module();
	return Kephra::Log::error("only callable by $api", 1) if $caller ne $api;
	return Kephra::Log::error("has to be called befor init", 1) if $done_init;
	return Kephra::Log::error("call me just once", 1) if keys %switchvar;
	return Kephra::Log::error("need a hashref", 1) unless ref $var_def eq 'HASH';
	for my $var (keys %$var_def){
		delete $var_def->{$var} unless substr($var, 0, 1) eq '$';
		delete $var_def->{$var} unless sub_exists( $api .'::'. $var_def->{$var}{'switch'} );
		delete $var_def->{$var} unless package_exists $INC{ $var_def->{$var}{'class'} };
	}
	%switchvar = %$var_def;
}

# register means: to be called before Command::init() - module body execution time
sub register_switch_var {
	my $var = shift;
	return Kephra::Log::error("need at least one var => sub relation (hash)", 1)
		unless ref $var eq 'HASH';
	my $calling_module = calling_module();
	no strict 'refs';
	for my $name (keys %$var){
		#return Kephra::Log::error #("$name already registered as ".$switch{'name'}{$name})
			#if exists $switch{'name'}{$name};
		$var->{$name} = $calling_module.'::'.$var->{$name}
			if index($var->{$name},'::') == -1;
		next, Kephra::Log::error("need name of existing sub, not name", 1) 
			if not sub_exists( $var->{$name} ) and $done_init;
		$switch{'name'}{$name} = $var->{$name}
			if $var->{$name} and defined &{ $var->{$name} };
	}
}

sub register_context_var {
	my $sub = shift;
	return Kephra::Log::error("need name of existing sub(string)", 1) unless defined $sub;
	my $calling_module = (caller)[0];
	$sub = $calling_module . '::' . $sub if index($sub, '::') == -1;
	return Kephra::Log::error("need name of existing sub(string), not $sub", 1)
		if not sub_exists($sub) and $done_init;
	$switch{'package'}{$calling_module} = $sub;
}



sub register {
	my $cmd = shift;
	return Kephra::Log::error( '"$cmd" has to be a hash ref', 1) unless ref $cmd eq 'HASH';
	my $calling_module = (caller)[0];
	for my $ID (keys %$cmd) {
		Kephra::Log::warning( 
			"$cmd already registered to do ". property($ID, 'sub')." by ".
			property($ID, 'source')  ), next if registered( $ID );
		#for (qw/sub options state event label help keys icon/){} filter input later
		$list{$ID}           = $cmd->{$ID};
		$list{$ID}{'source'} = $calling_module;
		compile($ID) if $done_init;
	}
}


sub init {
	compile( keys %list );
	for my $var (keys %{ $switch{'name'} }) {
		my $call = $switch{'name'}{$var};
		Kephra::Log::warning("$var has noneexisting switch call $call")
			unless sub_exists( $call );
	}
	for my $pkg (keys %{ $switch{'package'} }) {
		my $call = $switch{'package'}{$pkg};
		Kephra::Log::warning("$pkg has noneexisting context switch call $call")
			unless sub_exists( $call );
	}
	$done_init = 1;
}


sub compile {
	for my $cmd (@_) {
		my $data = $list{$cmd};
		my $call = $data->{'sub'};
		Kephra::Log::warning( "$cmd lacks value on hashkey 'sub'"), next unless $call;
		# insert start (prefix) of the call, module name mostly
		if (substr($call, 0, 1) eq '$'){
			if (substr($call, 1, 1) eq '_'){
				Kephra::Log::warning
					( "$cmd lacks switch declared by ".$data->{'source'}), next
						unless $switch{'package'}{ $data->{'source'} };
				$call = $switch{'package'}{ $data->{'source'}}.'()'.substr($call, 2);
			}
			else {
				my $vl = index($call,'->');
				my $switchvar = substr($call, 0, $vl);
				if (exists $switch{'name'}{$switchvar}){
					$call = $switch{'name'}{$switchvar}.'()'.substr($call, $vl)
				} else {
					Kephra::Log::error( "used unknown switchvar $switchvar", 1)
				}
			}
		}
		else { $call = $data->{'source'}.'::'.$call if index($call,'::') == -1 }
		#my $coderef = $call;
		#my $switchpos = index($coderef, '()->');
		#substr $coderef, $switchpos, 4, '::' if $switchpos > -1;
		#Kephra::Log::warning("$cmd calls nonexisting sub $call", 1)
		#	unless sub_exists( $coderef );

		# adding tail (suffix) of the call, signature part
		$call .= exists $data->{'parameter'} # just one parameter yet
			? '(\''.$data->{'parameter'}.'\')'
			: '()';
		$data->{'coderef'} = eval "sub { $call }";
		Kephra::API::KeyMap::register_keys( { $cmd => $data->{'keys'} } )
			if defined $data->{'keys'} and $data->{'keys'};
	}
}

sub run {
	my $cmd = shift;
	$cmd = [$cmd] unless ref $cmd eq ref [];
	my $return;
	for (@$cmd) { $return = $list{$_}{'coderef'}->() if exists $list{$_} }
	$return;
}
sub run_by_keycode {
	my ($code, $map) = @_;
}

sub registered      { 1 if defined $_[0]  and exists $list{ $_[0] }             }
sub property_exists { 1 if registered($_[0]) and exists $list{ $_[0] }{ $_[1] } }
sub add {}

sub all_properties { 
	if ( registered($_[0]) ) { $list{$_[0]} }
	else { Kephra::Log::warning('requested data of unknown command '.$_[0], 1) }
}
sub property       { $list{$_[0]}{$_[1]}         if property_exists(@_) }
sub set_property   { $list{$_[0]}{$_[1]} = $_[2] if property_exists(@_) }


1;

__END__

=head1 Command Definition

cmd_ID => {
	coderef   => compiled from sub, source and option, saves state
	sub       => 'Kephra::File::new',
	parameter => [],
	source    => package that registered that cmd
	state     => return value of the call or antother coderef
	event     => '',
	label     => 'New',
	help      => '', # help text to be shown in statusbar or as popup
	keys      => 'Ctrl + N',
	icon      => '',
	bitmap    => '',  #Wx::Bitmap Object
}