view release on metacpan or  search on metacpan

PPresenter/Decoration.pm  view on Meta::CPAN

package PPresenter::Decoration;

use strict;
use PPresenter::StyleElem;
use base 'PPresenter::StyleElem';

use constant ObjDefaults =>
{ type              => 'decoration'
, -bgcolor     => undef
, -fgcolor     => undef
, -bdcolor     => undef
, -backdrop    => undef

, -defaultBounds         => [ 0.05, 0.05, 0.97, 0.97 ]
, -notesBounds           => [ 0.02, 0.02, 0.98, 0.98 ]
, -defaultTitlebarHeight => 0.15
, -defaultFooterHeight   => 0.06
, -areaSeparation        => 0.03

, -titleBounds      => undef
, -mainBounds       => undef
, -mainBoundsNoTitle=> undef
, -footerBounds     => undef

, devices      =>
  # device       bgcolor      fgcolor   bdcolor  backdrop?
  { lcd     => [ 'dark blue', 'yellow', 'black', 1         ]
  , beamer  => [ 'white',     'black',  'gray',  0         ]
  , printer => [ 'white',     'black',  'gray',  0         ]
  }

, -nestImages  => ['640x480', 'greenball.gif', 'redball.gif', 'purpleball.gif' ]
};

sub InitObject()
{   my $deco = shift;

    $deco->check_nestImages(@{$deco->{-nestImages}});

    foreach (qw(-defaultTitlebarHeight -defaultFooterHeight -areaSeparation))
    {   next unless defined $deco->{$_};
        $deco->{$_} = $deco->toPercentage($deco->{$_});
    }

    foreach (qw(-defaultBounds -notesBounds -titleBounds -mainBounds
               -mainBoundsNoTitle -footerBounds))
    {   next unless defined $deco->{$_};
        $deco->{$_} = [ map {$deco->toPercentage($_)} @{$deco->{$_}} ];
    }
    
    $deco;
}

sub check_nestImages($@)
{   my ($deco, $geom) = (shift, shift);

    if(defined $geom)
    {   foreach (@_)
        {   next unless ref $_;
            next if $_->isa('PPresenter::Image::Magick');
            # Photo objects are already sized.
            die "-nestImages geometry only on filenames and Magick objects.\n";
        }
    }
    else
    {   foreach (@_)
        {   next unless ref @_;
            next if $_->isa('PPresenter::Image');
            die "-nestImages wants filenames or PPresenter::Image objects.\n";
        }
    }
}

sub addDevice($$$$)
{   my $deco = shift;
    unshift @{$deco->{devices}}, [ @_ ];
    $deco;
}

sub hasBackdrop($)
{   my ($deco,$device) = @_;

    return $deco->{-backdrop}
        if defined $deco->{-backdrop};

    my $spec = $deco->{devices}{$device} || undef;
    die "Undefined device $device.\n" unless defined $spec;
    $spec->[3];
}

sub color($$)
{   my ($deco, $view, $name) = @_;

    my $NAME   = uc $name;
    my $device = $view->device;
    my $spec   = $deco->{devices}{$device}
               || die "Undefined device $device\n";

    return $deco->{-bgcolor} || $spec->[0] if $NAME eq 'BGCOLOR';
    return $deco->{-fgcolor} || $spec->[1] if $NAME eq 'FGCOLOR';
    return $deco->{-bdcolor} || $spec->[2] if $NAME eq 'BDCOLOR';

    $name;
}

sub nestImageDef($$)
{   my ($deco, $nest) = @_;

    my $nr_images = @{$deco->{-nestImages}}-1;
    $nest = $nr_images-1 if $nest >= $nr_images;

    @{$deco->{-nestImages}}[0,$nest+1];
}

sub boundingBox($@)
{   my ($deco, $view) = (shift, shift);
    my ($w, $h) = $view->canvasDimensions;

    ( int(shift(@_) * $w), int(shift(@_) * $h)
    , int(shift(@_) * $w), int(shift(@_) * $h)