view release on metacpan or  search on metacpan

Prima/Classes.pm  view on Meta::CPAN

			$c3d[0], $c3d[1]
		);
	} else {
		push @c3d, $c3d[1], 0x404040;
	}

	if ( $opt{focused}) {
		my $hilite = $self->map_color(cl::Hilite);
		$_ = cl::blend( $self->map_color($_), $hilite, 0.5) for @c3d;
	}

	$fill = $fill->clone( widgetClass => $self->widgetClass ) if $fill && ref($fill);

	my $hw = int( $width / 2);
	$canvas-> rect3d( $x, $y, $x1, $y1, $hw, @c3d[2,3], $fill);
	$canvas-> rect3d( $x + $hw, $y + $hw, $x1 - $hw, $y1 - $hw, $width - $hw, @c3d[0,1]);
}

sub has_alpha_layer { $_[0]-> layered && $_[0]-> is_surface_layered }

sub begin_drag
{
	my ( $self, @opt ) = @_;
	my %opt;
	if ( 1 != @opt ) {
		%opt = @opt;
	} elsif ( ref($opt[0]) && $opt[0]->isa('Prima::Image')) {
		$opt{image} = $opt[0];
	} else {
		$opt{text} = $opt[0];
	}

	my $actions = ($opt{actions} // dnd::Copy) & dnd::Mask;
	unless ( $actions ) {
		Carp::carp("bad actions");
		return -1;
	}

	# don't start dragging immediately
	if ( $opt{track} // 1 ) {
		my @start_pos = $self->pointerPos;
		my $offset = $opt{track} // 5;
		my $break  = 0;
		my @id;
		push @id, $self-> add_notification( MouseMove => sub {
			my ( undef, undef, $x, $y ) = @_;
			$break = 1 if
				abs( $start_pos[0] - $x ) > $offset || 
				abs( $start_pos[1] - $y ) > $offset;
		});
		push @id, 
			map { $self-> add_notification( $_ => sub { $break = -1 }) }
			qw(MouseLeave MouseClick MouseDown MouseUp Destroy);
		1 while !$break && $::application->yield(1);
		return dnd::None unless $self->alive;
		$self->remove_notification($_) for @id;
		return -1 if $break < 0;
	}

	# data
	my $clipboard = $::application->get_dnd_clipboard;
	if ( exists $opt{text}) {
		$clipboard->text($opt{text});
		$opt{preview} //= $opt{text};
	} elsif ( exists $opt{image}) {
		$clipboard->image($opt{image});
		$opt{preview} //= $opt{image};
	} elsif ( exists $opt{format} and exists $opt{data}) {
		$clipboard->copy($opt{format}, $opt{data});
	} # or else you fill the clipboard yourself

	my @id;
	my %pointers;
	my $last_action = -1;
	$opt{preview} = undef unless $::application->get_system_value(sv::ColorPointer);

	my @max = map { $_ / 8 } $::application->size;
	if ( $opt{preview} && !ref($opt{preview}) ) {
		my @lines = split "\n", $opt{preview};
		my $fh    = $self->font->height;
		my @sz = ( 0, 10 + $fh * @lines );
		for my $text ( @lines ) {
			my $tw = $self->get_text_shape_width($text, 1);
			$sz[0] = $tw if $sz[0] < $tw;
		}
		$sz[0] += 10;
		$sz[0] = $max[0] if $sz[0] > $max[0];
		$sz[1] = $max[1] if $sz[1] > $max[1];
		my $i = Prima::Icon->new(
			size      => \@sz,
			type      => im::RGB,
			color     => $self->color,
			backColor => $self->backColor,
			font      => $self->font,
			autoMasking => am::None,
			maskType    => im::bpp8,
		);
		$i->begin_paint;
		$i->clear;
		my $y = $i->height - $fh - 5;
		for my $text ( @lines ) {
			$i->text_shape_out( $text, 5, $y);
			$y -= $fh;
		}
		$i->end_paint;
		$i->bar_alpha(160, 0, 0, $i->size);
		$opt{preview} = $i;
	}

	if ( my $p = $opt{preview}) {
		my @sz = $p->size;
		$opt{preview} = $p->extract(0, 0,
			($sz[0] > $max[0]) ? $max[0] : $sz[0],
			($sz[1] > $max[1]) ? $max[1] : $sz[1],
		) if $sz[0] > $max[0] || $sz[1] > $max[1];
	}

	# select multi actions
	unless (dnd::is_one_action($actions)) {
		my $default_action = dnd::to_one_action($actions);
		push @id, $self-> add_notification( DragQuery => sub {
			my ( $self, $modmap, $counterpart, $ref ) = @_;
			if ( $modmap & km::Ctrl and $actions & dnd::Move ) {
				$ref->{action} = dnd::Move;
			} elsif ( $modmap & km::Shift and $actions & dnd::Link ) {
				$ref->{action} = dnd::Link;
			} else {
				$ref->{action} = $default_action;
			}
		});

Prima/Classes.pm  view on Meta::CPAN

		pointerType    => cr::Arrow,
		pointerVisible => 1,
		language       => Prima::Application->get_system_info->{guiLanguage},
		guiException   => $GUI_EXCEPTION,
		icon           => undef,
		owner          => undef,
		scaleChildren  => 0,
		ownerColor     => 0,
		ownerBackColor => 0,
		ownerFont      => 0,
		ownerShowHint  => 0,
		ownerPalette   => 0,
		showHint       => 1,
		hintClass      => 'Prima::HintWidget',
		hintColor      => cl::Black,
		hintBackColor  => 0xffff80,
		hintPause      => 800,
		hintFont       => Prima::Widget::get_default_font,
		modalHorizon   => 1,
		printerClass   => $unix ? 'Prima::PS::Printer' : 'Prima::Printer',
		printerModule  => $unix ? 'Prima::PS::Printer' : '',
		helpClass      => 'Prima::HelpViewer',
		helpModule     => 'Prima::HelpViewer',
		textDirection  => 0,
		uiScaling      => 0,
		wantUnicodeInput => 1,
	);
	@$def{keys %prf} = values %prf;
	return $def;
}

sub profile_check_in
{
	my ( $self, $p, $default) = @_;
	$p->{textDirection} //= $self->lang_is_rtl($p->{language} // $default->{language});
	$GUI_EXCEPTION = delete $p->{guiException} if exists $p->{guiException};
	$self-> SUPER::profile_check_in( $p, $default);
	delete $p-> { printerModule};
	delete $p-> { owner};
	delete $p-> { ownerColor};
	delete $p-> { ownerBackColor};
	delete $p-> { ownerFont};
	delete $p-> { ownerShowHint};
	delete $p-> { ownerPalette};
}

sub add_startup_notification
{
	shift if ref($_[0]) ne 'CODE'; # skip class reference, if any
	if ( $::application) {
		$_-> ($::application) for @_;
	} else {
		push( @startupNotifications, @_);
	}
}

sub setup
{
	my $self = $::application = shift;
	$self-> SUPER::setup;
	for my $clp (Prima::Clipboard-> get_standard_clipboards()) {
		$self-> {$clp} = $self-> insert( qw(Prima::Clipboard), name => $clp)
			unless exists $self-> {$clp};
	}
	$_-> ($self) for @startupNotifications;
	undef @startupNotifications;

	# setup image cliboard transfer routines specific to gtk
	if ( $unix ) {
		my %weights = (
			png  => 4,  # png is lossless
			bmp  => 3,  # bmp is independent on codecs but huge
			tiff => 2,  # tiff is usually lossless
		);
		my %codecs  = map { lc($_-> {fileShortType})  => $_ } @{Prima::Image-> codecs};
		$_->{weight} = $weights{ lc($_-> {fileShortType}) } || 1 for values %codecs;
		my @codecs = map { {
			mime => "image/$_",
			id   => $codecs{$_}->{codecID},
			w    => $codecs{$_}->{weight},
		} } sort { $codecs{$b}->{weight} <=> $codecs{$a}->{weight} } keys %codecs;
		my $clipboard = $self-> Clipboard;
		$clipboard-> register_format($_->{mime}) for @codecs;
		$self-> {GTKImageClipboardFormats} = \@codecs;
	}
}

sub get_fullscreen_image
{
	my $self = shift;
	if ( $^O eq 'darwin') {
		require Prima::sys::XQuartz;
		return Prima::sys::XQuartz::get_fullscreen_image($self);
	} else {
		return $self->get_image(0,0,$self->size);
	}
}

sub get_printer
{
	unless ( $_[0]-> {Printer}) {
		if ( length $_[0]-> {PrinterModule}) {
			eval 'use ' . $_[0]-> {PrinterModule} . ';';
			die "$@" if $@;
		}
		$_[0]-> {Printer} = $_[0]-> {PrinterClass}-> create( owner => $_[0], system => 1);
	}
	return $_[0]-> {Printer};
}

sub guiException  {$#_ ? $GUI_EXCEPTION = $_[1] : $GUI_EXCEPTION }
sub hintFont      {($#_)?$_[0]-> set_hint_font        ($_[1])  :return Prima::Font-> new($_[0], "get_hint_font", "set_hint_font")}
sub helpModule    {($#_)?$_[0]-> {HelpModule} = $_[1] : return $_[0]-> {HelpModule}}
sub helpClass     {($#_)?$_[0]-> {HelpClass}  = $_[1] : return $_[0]-> {HelpClass}}

sub lang_is_rtl
{
	my $lang = $_[1] // $_[0]->get_system_info->{guiLanguage};
	$lang =~ /^(
		ar| # arabic
		dv| # divehi
		fa| # persian (farsi)
		ha| # hausa
		he| # hebrew
		iw| # hebrew (old code)
		ji| # yiddish (old code)
		ps| # pashto, pushto
		ur| # urdu
		yi  # yiddish
	)/x ? 1 : 0
}

sub language
{
	return $_[0]->{language} unless $#_;
	my ( $self, $lang ) = @_;
	$self->{language} = $lang;
	$self->textDirection( $_[0]-> lang_is_rtl($lang));
}

sub help_init
{
	return 0 unless length $_[0]-> {HelpModule};
	eval 'use ' . $_[0]-> {HelpModule} . ';';
	die "$@" if $@;
	return 1;
}

sub close_help
{
	return '' unless $_[0]-> help_init;
	shift-> {HelpClass}-> close;
}

sub open_help
{
	my ( $self, $link) = @_;
	return unless length $link;
	return unless $self-> help_init;
	return $self-> {HelpClass}-> open($link);
}

sub on_die
{
	my ($self, $err, $stack) = @_;
	return unless $GUI_EXCEPTION;
	require Prima::MsgBox;
	$self->clear_event if
		Prima::MsgBox::signal_dialog($self->name . ' fatal error', $err, $stack) != mb::Abort;
}

sub on_clipboard
{
	my ( $self, $clipboard, $action, $target ) = @_;
	if ($clipboard->format_exists('Image')) {
		if ( my ( $codec ) = grep { $target eq $_->{mime} } @{ $self-> {GTKImageClipboardFormats} // [] }) {
			my ($bits, $handle) = ('');
			my $i = $clipboard->fetch('Image') or return;
			if (open( $handle, '>', \$bits) and $i->save($handle, codecID => $codec->{id})) {
				$clipboard->store($codec->{mime}, $bits);
			}
		}
	}
}

sub on_copy
{
	my ( $self, $format, $clipboard, $data ) = @_;
	$clipboard-> store( $format, $data);
	if ( $format eq 'Image') {
		# store(undef) is a special flag for x11 when data can be provided on demand for this format
		$clipboard->store($_, undef) for map { $_->{mime} } @{ $self-> {GTKImageClipboardFormats} // [] };
	}
}

sub on_formatexists
{
	my ( $self, $format, $clipboard, $ref) = @_;

	if ( $format eq 'Text') {
		if ( $self-> wantUnicodeInput) {
			return $$ref = 'UTF8' if $clipboard-> format_exists( 'UTF8');
		}
		$$ref = $clipboard-> format_exists( $format ) ? $format : undef;
	} elsif ( $format eq 'Image') {
		$$ref = undef;
		return $$ref = 'Image' if $clipboard-> format_exists( 'Image');
		my $codecs = $self-> {GTKImageClipboardFormats} or return;
		my %formats = map { $_ => 1 } $clipboard-> get_formats;
		my @codecs  = grep { $formats{$_->{mime}} } @$codecs or return;
		$$ref = $codecs[0]->{mime} if $clipboard-> format_exists($codecs[0]->{mime});
	} else {
		$$ref = $clipboard-> format_exists( $format ) ? $format : undef;
	}
	undef;
}

sub on_paste
{
	my ( $self, $format, $clipboard, $ref) = @_;

	if ( $format eq 'Text') {
		if ( $self-> wantUnicodeInput) {
			return if defined ( $$ref = $clipboard-> fetch( 'UTF8'));
		}
		$$ref = $clipboard-> fetch( 'Text');
	} elsif ( $format eq 'Image') {
		my $codecs  = $self-> {GTKImageClipboardFormats} or goto DEFAULT;
		my %formats = map  { $_ => 1 } $clipboard-> get_formats;
		my @codecs  = grep { $formats{$_->{mime}} && $_->{w} > 1 } @$codecs or goto DEFAULT;
		my $data    = $clipboard-> fetch($codecs[0]->{mime});
		return unless defined $data;

		my $handle;
		open( $handle, '<', \$data) or return;

		local $@;
		$$ref = Prima::Image-> load($handle, loadExtras => 1 );
	} else {
	DEFAULT:
       		$$ref = $clipboard-> fetch( $format);
	}
	undef;
}

1;

=pod

=head1 NAME

Prima::Classes - binder module for the built-in classes.

=head1 DESCRIPTION

C<Prima::Classes> and L<Prima::Const> is a minimal set of perl modules needed for
the toolkit. Since the module provides bindings for the core classes, it is required
to be included in every Prima-related module and program.

=head1 AUTHOR

Dmitry Karasik, E<lt>dmitry@karasik.eu.orgE<gt>.

=head1 SEE ALSO

L<Prima>, L<Prima::Const>


=cut