Source

Kephra / lib / Kephra / App / Util.pm

Full commit
use strict;
use warnings;

package Kephra::App::Util;

sub get {
	my ($ref, @method_ref);
	die unless @_;
	for my $subname (@_){
		eval { $ref = \&{__PACKAGE__ . "::$subname"} };
		if ($@) { die "__PACKAGE__::get : no $subname sub in this Module." }
		else    { push @method_ref, $ref }
	}
	if (wantarray){ return @method_ref }
	else          { return $method_ref[0] }
}

sub is_object { return 1 if ref $_[0] and index($_[0], '=') > -1 }
sub is_widget { return 1 if is_object( $_[0] ) and $_[0]->isa('Wx::Window') }
sub is_panel  { return 1 if is_object( $_[0] )
			and ($_[0]->isa('Wx::Panel') or $_[0]->isa('Kephra::App::Panel') )
}
sub is_sizer  { ( is_object( $_[0] ) and $_[0]->isa('Wx::Sizer') ) ? 1 : 0 }
sub is_color  { ( is_object( $_[0] ) and $_[0]->isa('Wx::Colour') and $_[0]->IsOk ) ? 1 : 0 }

sub create_color {
	my ($r, $g, $b, $t ) = @_;
	my $name = __PACKAGE__ . '::make_color';
	my $usage = "$name takes 1 parameter (hex-'12345f' or dec-'0,0,1' or name) or 3 parameters (R, G, B)";
	die "not enough parmaters\n$usage" unless defined $r;
	unless (defined $g){
		# handle hex format like in HTML: #234567
		if ( $r =~ /^#?([0-9a-f]{2})([0-9a-f]{2})([0-9a-f]{2})$/i ) {
			($r,$g,$b) = ( hex $1, hex $2, hex $3 );
		}
		# handle comma-seperated format: 0,0,125
		elsif ( $r =~ /^(\d+),\s*(\d+),\s*(\d+)$/ ) {
			($r,$g,$b) = ( $1+0, $2+0, $3+0 );
		} else {
			my %color = (
				'white' => [255, 255, 255],
				'red'   => [255,   0,   0],
				'orange'=> [255, 127,   0],
				'yellow'=> [255, 255,   0],
				'green' => [  0, 255,   0],
				'cyan'  => [  0, 255, 255],
				'blue'  => [  0,   0, 255],
				'purple'=> [255,   0, 255],
				'violet'=> [255,   0, 255],
				'grey'  => [180, 180, 180],
				'black' => [  0,   0,   0],
			);
			if ( exists $color{lc $r} ) {  ( $r, $g, $b ) = @{ $color{lc $r} }  }
			else {
				my $c = Wx::ColourDatabase::Find( $r );
				return $c if is_color( $c );
			}
			unless (defined $g) {
				my @clist = ( (keys %color),
					'AQUAMARINE', 'BLACK', 'BLUE', 'BLUE VIOLET', 'BROWN',
					'CADET BLUE', 'CORAL', 'CORNFLOWER BLUE', 'CYAN', 'DARK GREY',
					'DARK GREEN', 'DARK OLIVE GREEN', 'DARK ORCHID', 'DARK SLATE BLUE',
					'DARK SLATE GREY', 'DARK TURQUOISE, DIM GREY, FIREBRICK',
					'FOREST GREEN', 'GOLD', 'GOLDENROD', 'GREY, GREEN', 'GREEN YELLOW',
					'INDIAN RED', 'KHAKI', 'LIGHT BLUE', 'LIGHT GREY', 'LIGHT STEEL BLUE',
					'LIME GREEN', 'MAGENTA', 'MAROON', 'MEDIUM AQUAMARINE', 'MEDIUM BLUE',
					'MEDIUM FOREST GREEN', 'MEDIUM GOLDENROD', 'MEDIUM ORCHID', 
					'MEDIUM SEA GREEN', 'MEDIUM SLATE BLUE', 'MEDIUM SPRING GREEN',
					'MEDIUM TURQUOISE', 'MEDIUM VIOLET RED', 'MIDNIGHT BLUE, NAVY',
					'ORANGE', 'ORANGE RED', 'ORCHID', 'PALE GREEN', 'PINK', 'PLUM',
					'PURPLE', 'RED, SALMON', 'SEA GREEN', 'SIENNA', 'SKY BLUE',
					'SLATE BLUE', 'SPRING GREEN', 'STEEL BLUE', 'TAN', 'THISTLE',
					'TURQUOISE', 'VIOLET', 'VIOLET RED', 'WHEAT', 'WHITE', 'YELLOW',
					'YELLOW GREEN',
				);
				die "$r is an unknow color name, just know @clist";
			}
		}
	}
	die "not enough parmaters or bad format\n$usage" unless defined $b;
	die "too much parmaters\n$usage" if defined $t;
	die "red definition is outside of 0..255" unless int $r == $r && $r>=0 && $r<=255;
	die "green definition is outside of 0..255" unless int $g == $g && $g>=0 && $g<=255;
	die "blue definition is outside of 0..255" unless int $b == $b && $b>=0 && $b<=255;
	return Wx::Colour->new($r, $g, $b);
}

sub lounch_browser { Wx::LaunchDefaultBrowser($_[0]) }

1;

__END__

	#my $normal_font = Wx::Font->new (
		#12, 
		#&Wx::wxFONTFAMILY_DEFAULT,
		#&Wx::wxFONTSTYLE_NORMAL,
		#&Wx::wxFONTWEIGHT_NORMAL,
		#0,
	#);
	#my $highlight_font = Wx::Font->new (
		#12, 
		#&Wx::wxFONTFAMILY_TELETYPE,
		#&Wx::wxFONTSTYLE_NORMAL,
		#&Wx::wxFONTWEIGHT_BOLD,
		#1,
	#);