view release on metacpan or  search on metacpan

Prima/Classes.pm  view on Meta::CPAN

{
	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