libprima-perl 1.28-1.1 / usr / lib / perl5 / Prima / Widgets.pm

#
#  Copyright (c) 1997-2002 The Protein Laboratory, University of Copenhagen
#  All rights reserved.
#
#  Redistribution and use in source and binary forms, with or without
#  modification, are permitted provided that the following conditions
#  are met:
#  1. Redistributions of source code must retain the above copyright
#     notice, this list of conditions and the following disclaimer.
#  2. Redistributions in binary form must reproduce the above copyright
#     notice, this list of conditions and the following disclaimer in the
#     documentation and/or other materials provided with the distribution.
#
#  THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
#  ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
#  IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
#  ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
#  FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
#  DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
#  OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
#  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
#  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
#  OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
#  SUCH DAMAGE.
#
#  Created by Dmitry Karasik <dmitry@karasik.eu.org>
#
#  $Id: Widgets.pm,v 1.11 2005/10/13 17:22:51 dk Exp $

# contains:
#   Panel

use strict;
use Prima::Const;
use Prima::Classes;

package Prima::Panel;
use vars qw(@ISA);
@ISA = qw(Prima::Widget);

sub profile_default
{
	my $def = $_[0]-> SUPER::profile_default;
	my %prf = (
		ownerBackColor => 1,
		raise          => 1,
		borderWidth    => 1,
		image          => undef,
		imageFile      => undef,
		zoom           => 1,
	);
	@$def{keys %prf} = values %prf;
	return $def;
}

sub profile_check_in
{
	my ( $self, $p, $default) = @_;
	$self-> SUPER::profile_check_in( $p, $default);
	if ( defined $p-> {imageFile} && !defined $p-> {image}) {
		$p-> {image} = Prima::Image-> create;
		delete $p-> {image} unless $p-> {image}-> load($p-> {imageFile});
	}
}

sub init
{
	my $self = shift;
	for ( qw( image ImageFile))
		{ $self-> {$_} = undef; }
	for ( qw( zoom raise borderWidth iw ih)) { $self-> {$_} = 1; }
	my %profile = $self-> SUPER::init(@_);
	$self-> { imageFile}  = $profile{ imageFile};
	for ( qw( image zoom borderWidth raise)) {
		$self-> $_($profile{$_});
	}
	return %profile;
}

sub on_paint
{
	my ( $self, $canvas) = @_;
	my @size   = $canvas-> size;

	my $clr    = $self-> backColor;
	my $bw     = $self-> {borderWidth};
	my @c3d    = ( $self-> light3DColor, $self-> dark3DColor);
	@c3d = reverse @c3d unless $self-> {raise};
	my $cap = $self-> text;
	unless ( defined $self-> {image}) {
		$canvas-> rect3d( 0, 0, $size[0]-1, $size[1]-1, $bw, @c3d, $clr);
		$canvas-> text_out( $cap,
			( $size[0] - $canvas-> get_text_width( $cap)) / 2,
			( $size[1] - $canvas-> font-> height) / 2,
		) if defined $cap;
		return;
	}
	$canvas-> rect3d( 0, 0, $size[0]-1, $size[1]-1, $bw, @c3d) if $bw > 0;
	my ( $x, $y) = ( $bw, $bw);
	my ( $dx, $dy ) = ( $self-> {iw}, $self-> {ih});
	$canvas-> clipRect( $bw, $bw, $size[0] - $bw - 1, $size[1] - $bw - 1) if $bw > 0;
	$canvas-> clear if $self-> {image}-> isa('Prima::Icon');
	while ( $x < $size[0] - $bw) {
		$y = $bw;
		while ( $y < $size[1] - $bw) {
			$canvas-> stretch_image( $x, $y, $dx, $dy, $self-> {image});
			$y += $dy;
		}
		$x += $dx;
	}
	$canvas-> text_out ( $cap,
		( $size[0] - $canvas-> get_text_width( $cap)) / 2,
		( $size[1] - $canvas-> font-> height) / 2,
	) if $cap;
}

sub set_border_width
{
	my ( $self, $bw) = @_;
	$bw = 0 if $bw < 0;
	$bw = int( $bw);
	return if $bw == $self-> {borderWidth};
	$self-> {borderWidth} = $bw;
	$self-> repaint;
}

sub text
{
	return $_[0]-> SUPER::text unless $#_;
	$_[0]-> SUPER::text( $_[1]);
	$_[0]-> repaint;
}


sub set_raise
{
	my ( $self, $r) = @_;
	return if $r == $self-> {raise};
	$self-> {raise} = $r;
	$self-> repaint;
}

sub set_image_file
{
	my ($self,$file,$img) = @_;
	$img = Prima::Image-> create;
	return unless $img-> load($file);
	$self-> {imageFile} = $file;
	$self-> image($img);
}

sub set_image
{
	my ( $self, $img) = @_;
	$self-> {image} = $img;
	return unless defined $img;
	( $self-> {iw}, $self-> {ih}) = ($img-> width * $self-> {zoom}, $img-> height * $self-> {zoom});
	$self-> {image} = undef if $self-> {ih} == 0 || $self-> {iw} == 0;
	$self-> repaint;
}


sub set_zoom
{
	my ( $self, $zoom) = @_;
	$zoom = int( $zoom);
	$zoom = 1 if $zoom < 1;
	$zoom = 10 if $zoom > 10;
	return if $zoom == $self-> {raise};
	$self-> {zoom} = $zoom;
	return unless defined $self-> {image};
	my $img = $self-> {img};
	( $self-> {iw}, $self-> {ih}) = ( $img-> width * $self-> {zoom}, $img-> height * $self-> {zoom});
	$self-> repaint;
}

sub image        {($#_)?$_[0]-> set_image($_[1]):return $_[0]-> {image} }
sub imageFile    {($#_)?$_[0]-> set_image_file($_[1]):return $_[0]-> {imageFile}}
sub zoom         {($#_)?$_[0]-> set_zoom($_[1]):return $_[0]-> {zoom}}
sub borderWidth  {($#_)?$_[0]-> set_border_width($_[1]):return $_[0]-> {borderWidth}}
sub raise        {($#_)?$_[0]-> set_raise($_[1]):return $_[0]-> {raise}}

1;

__DATA__

=pod

=head1 NAME

Prima::Widgets - miscellaneous widget classes

=head1 DESCRIPTION

The module was designed to serve as a collection of small widget
classes that do not group well with the other, more purposeful classes.
The current implementation contains the only class, C<Prima::Panel>.

=head1 Prima::Panel

Provides a simple panel widget, capable of displaying a single line
of centered text on a custom background. Probably this functionality
is better to be merged into C<Prima::Label>'s.

=head2 Properties

=over

=item borderWidth INTEGER

Width of 3d-shade border around the widget.

Default value: 1

=item image OBJECT

Selects image to be drawn as a tiled background.
If C<undef>, the background is drawn with the background color.

=item imageFile PATH

Set the image FILE to be loaded and displayed. Is rarely used since does not return
a loading success flag.

=item raise BOOLEAN

Style of 3d-shade border around the widget.
If 1, the widget is 'risen'; if 0 it is 'sunken'.

Default value: 1

=item zoom INTEGER

Selects zoom level for image display. 
The acceptable value range is between 1 and 10. 

Default value: 1

=back

=head1 AUTHOR

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

=head1 SEE ALSO

L<Prima>

=cut