Prima
view release on metacpan or search on metacpan
Prima/Classes.pm view on Meta::CPAN
Move => nt::Default,
Paint => nt::Action,
Popup => nt::Command,
Setup => nt::Default,
Show => nt::Default,
Size => nt::Default,
TranslateAccel => nt::Default,
SysHandle => nt::Default,
ZOrderChanged => nt::Default,
);
sub notification_types { return \%RNT; }
}
%WidgetProfile = (
accelTable => undef,
accelItems => undef,
autoEnableChildren=> 0,
backColor => cl::Normal,
briefKeys => 1,
buffered => 0,
clipChildren => 1,
capture => 0,
clipOwner => 1,
color => cl::NormalText,
bottom => 100,
centered => 0,
current => 0,
currentWidget => undef,
cursorVisible => 0,
dark3DColor => cl::Dark3DColor,
disabledBackColor => cl::Disabled,
disabledColor => cl::DisabledText,
dndAware => 0,
enabled => 1,
firstClick => 1,
focused => 0,
geometry => gt::GrowMode,
growMode => 0,
height => 100,
helpContext => '',
hiliteBackColor => cl::Hilite,
hiliteColor => cl::HiliteText,
hint => '',
hintVisible => 0,
layered => 0,
light3DColor => cl::Light3DColor,
left => 100,
ownerColor => 0,
ownerBackColor => 0,
ownerFont => 1,
ownerHint => 1,
ownerShowHint => 1,
ownerPalette => 1,
packInfo => undef,
packPropagate => 1,
placeInfo => undef,
pointerIcon => undef,
pointer => cr::Default,
pointerType => cr::Default,
popup => undef,
popupColor => cl::NormalText,
popupBackColor => cl::Normal,
popupHiliteColor => cl::HiliteText,
popupHiliteBackColor => cl::Hilite,
popupDisabledColor => cl::DisabledText,
popupDisabledBackColor => cl::Disabled,
popupLight3DColor => cl::Light3DColor,
popupDark3DColor => cl::Dark3DColor,
popupItems => undef,
right => 200,
scaleChildren => 1,
selectable => 0,
selected => 0,
selectedWidget => undef,
selectingButtons => mb::Left,
shape => undef,
showHint => 1,
syncPaint => 0,
tabOrder => -1,
tabStop => 1,
text => undef,
textOutBaseline => 0,
top => 200,
transparent => 0,
visible => 1,
widgetClass => wc::Custom,
widgets => undef,
width => 100,
x_centered => 0,
y_centered => 0,
);
sub profile_default
{
my $def = $_[ 0]-> SUPER::profile_default;
@$def{keys %WidgetProfile} = values %WidgetProfile;
my %WidgetProfile = (
# secondary; contains anonymous arrays that must be generated at every invocation
cursorPos => [ 0, 0],
cursorSize => [ 12, 3],
designScale => [ 0, 0],
origin => [ 0, 0],
owner => $::application,
pointerHotSpot => [ 0, 0],
rect => [ 0, 0, 100, 100],
size => [ 100, 100],
sizeMin => [ 0, 0],
sizeMax => [ 16384, 16384],
);
@$def{keys %WidgetProfile} = values %WidgetProfile;
@$def{qw( font popupFont)} = ( $_[ 0]-> get_default_font, $_[ 0]-> get_default_popup_font);
return $def;
}
sub profile_check_in
{
my ( $self, $p, $default) = @_;
my $orgFont = exists $p-> { font} ? $p-> { font} : undef;
my $owner = exists $p-> { owner} ? $p-> { owner} : $default-> { owner};
$self-> SUPER::profile_check_in( $p, $default);
delete $p-> { font} unless defined $orgFont;
for my $tx ( qw(text hint)) {
$p->{$tx} = $self->_parse_markup($tx, $p->{$tx}) if defined $p->{$tx} && (ref($p->{$tx}) // '') eq 'SCALAR';
}
my $name = defined $p-> {name} ? $p-> {name} : $default-> {name};
$p-> {text} = $name
if !defined $p-> { text} and !defined $default-> {text};
$p-> {showHint} = 1 if
( defined $owner) &&
( defined $::application) &&
( $owner == $::application) &&
( exists $p-> { ownerShowHint} ?
$p-> { ownerShowHint} :
$default-> { ownerShowHint}
);
$p-> {enabled} = $owner-> enabled
if defined $owner && $owner-> autoEnableChildren;
(my $cls = ref $self) =~ s/^Prima:://;
for my $fore (qw(color hiliteBackColor disabledColor dark3DColor)) {
unless (exists $p-> {$fore}) {
my $clr = Prima::Widget::fetch_resource(
$cls, $name, 'Foreground',
$fore, $owner, fr::Color
);
$p-> {$fore} = $clr if defined $clr;
}
}
for my $back (qw(backColor hiliteColor disabledBackColor light3DColor)) {
unless (exists $p-> {$back}) {
my $clr = Prima::Widget::fetch_resource(
$cls, $name, 'Background',
$back, $owner, fr::Color
);
$p-> {$back} = $clr if defined $clr;
}
}
for my $fon (qw(font popupFont)) {
my $f = Prima::Widget::fetch_resource(
$cls, $name, 'Font', $fon, $owner, fr::Font);
next unless defined $f;
unless ( exists $p-> {$fon}) {
$p-> {$fon} = $f;
} else {
for ( keys %$f) {
$p-> {$fon}-> {$_} = $$f{$_}
unless exists $p-> {$fon}-> {$_};
}
}
}
for ( $owner ? qw( color backColor showHint hint font): ()) {
my $o_ = 'owner' . ucfirst $_;
$p-> { $_} = $owner-> $_() if
( $p-> { $o_} = exists $p-> { $_} ? 0 :
( exists $p-> { $o_} ? $p-> { $o_} : $default-> {$o_}));
}
for ( qw( font popupFont)) {
$p-> { $_} = {} unless exists $p-> { $_};
$p-> { $_} = Prima::Widget-> font_match( $p-> { $_}, $default-> { $_});
}
if ( exists( $p-> { origin})) {
$p-> { left } = $p-> { origin}-> [ 0];
$p-> { bottom} = $p-> { origin}-> [ 1];
}
if ( exists( $p-> { rect})) {
my $r = $p-> { rect};
$p-> { left } = $r-> [ 0];
$p-> { bottom} = $r-> [ 1];
$p-> { right } = $r-> [ 2];
$p-> { top } = $r-> [ 3];
}
if ( exists( $p-> { size})) {
$p-> { width } = $p-> { size}-> [ 0];
$p-> { height} = $p-> { size}-> [ 1];
}
my $designScale = exists $p-> {designScale} ? $p-> {designScale} : $default-> {designScale};
if ( defined $designScale) {
my @defScale = @$designScale;
if (( $defScale[0] > 0) && ( $defScale[1] > 0)) {
@{$p-> { designScale}} = @defScale;
for ( qw ( left right top bottom width height)) {
$p-> {$_} = $default-> {$_}
unless exists $p-> {$_};
}
} else {
@defScale = $owner-> designScale
if defined $owner && $owner-> scaleChildren;
@{$p-> { designScale}} = @defScale
if ( $defScale[0] > 0) && ( $defScale[1] > 0);
}
if ( exists $p-> { designScale}) {
my @d = @{$p-> { designScale}};
unless ( @default_font_box) {
my $f = $::application-> get_default_font;
@default_font_box = ( $f-> { width}, $f-> { height});
}
my @a = @default_font_box;
$p->{$_} = int($p->{$_} * $a[0] / $d[0] + .5) for grep { exists $p->{$_} } qw(left right width);
$p->{$_} = int($p->{$_} * $a[1] / $d[1] + .5) for grep { exists $p->{$_} } qw(top bottom height);
}
} else {
$p-> {designScale} = [0,0];
}
$p-> { top} = $default-> { bottom} + $p-> { height}
if ( !exists ( $p-> { top}) && !exists( $p-> { bottom}) && exists( $p-> { height}));
$p-> { height} = $p-> { top} - $p-> { bottom}
if ( !exists( $p-> { height}) && exists( $p-> { top}) && exists( $p-> { bottom}));
$p-> { top} = $p-> { bottom} + $p-> { height}
if ( !exists( $p-> { top}) && exists( $p-> { height}) && exists( $p-> { bottom}));
$p-> { bottom} = $p-> { top} - $p-> { height}
if ( !exists( $p-> { bottom}) && exists( $p-> { height}) && exists( $p-> { top}));
$p-> { bottom} = $p-> { top} - $default-> { height}
if ( !exists( $p-> { bottom}) && !exists( $p-> { height}) && exists( $p-> { top}));
$p-> { top} = $p-> { bottom} + $default-> { height}
if ( !exists( $p-> { top}) && !exists( $p-> { height}) && exists( $p-> { bottom}));
$p-> { right} = $default-> { left} + $p-> { width}
if ( !exists( $p-> { right}) && !exists( $p-> { left}) && exists( $p-> { width}));
$p-> { width} = $p-> { right} - $p-> { left}
if ( !exists( $p-> { width}) && exists( $p-> { right}) && exists( $p-> { left}));
$p-> { right} = $p-> { left} + $p-> { width}
if ( !exists( $p-> { right}) && exists( $p-> { width}) && exists( $p-> { left}));
$p-> { left} = $p-> { right} - $p-> { width}
if ( !exists( $p-> { left}) && exists( $p-> { right}) && exists( $p-> { width}));
$p-> { left} = $p-> { right} - $default-> {width}
if ( !exists( $p-> { left}) && !exists( $p-> { width}) && exists($p-> {right}));
$p-> { right} = $p-> { left} + $default-> { width}
if ( !exists( $p-> { right}) && !exists( $p-> { width}) && exists( $p-> { left}));
if ( $p-> { popup}) {
$p-> { popupItems} = $p-> {popup}-> get_items('');
delete $p-> {popup};
}
my $current = exists $p-> { current} ? $p-> { current} : $default-> { current};
if ( defined($owner) && !$current && !$owner-> currentWidget) {
my $e = exists $p-> { enabled} ? $p-> { enabled} : $default-> { enabled};
my $v = exists $p-> { visible} ? $p-> { visible} : $default-> { visible};
$p-> {current} = 1 if $e && $v;
}
if ( exists $p-> {pointer}) {
my $pt = $p-> {pointer};
$p-> {pointerType} = ( ref($pt) ? cr::User : $pt)
if !exists $p-> {pointerType};
$p-> {pointerIcon} = $pt
if !exists $p-> {pointerIcon} && ref( $pt);
$p-> {pointerHotSpot} = $pt-> {__pointerHotSpot}
if !exists $p-> {pointerHotSpot} && ref( $pt) && exists $pt-> {__pointerHotSpot};
}
if ( exists $p-> {pack}) {
for ( keys %{$p-> {pack}}) {
s/^-//; # Tk syntax
$p-> {packInfo}-> {$_} = $p-> {pack}-> {$_}
unless exists $p-> {packInfo}-> {$_};
}
$p-> {geometry} = gt::Pack unless exists $p-> {geometry};
}
$p-> {packPropagate} = 0 if !exists $p-> {packPropagate} &&
( exists $p-> {width} || exists $p-> {height});
if ( exists $p-> {place}) {
for ( keys %{$p-> {place}}) {
s/^-//; # Tk syntax
$p-> {placeInfo}-> {$_} = $p-> {place}-> {$_}
unless exists $p-> {placeInfo}-> {$_};
}
$p-> {geometry} = gt::Place unless exists $p-> {geometry};
}
}
sub capture {($#_)?shift-> set_capture (@_) :return $_[0]-> get_capture; }
sub centered {($#_)?$_[0]-> set_centered(1,1) :$_[0]-> raise_wo("centered"); }
sub dark3DColor {return shift-> colorIndex( ci::Dark3DColor , @_)};
sub disabledBackColor {return shift-> colorIndex( ci::Disabled , @_)};
sub disabledColor {return shift-> colorIndex( ci::DisabledText, @_)};
sub hiliteBackColor {return shift-> colorIndex( ci::Hilite , @_)};
sub hiliteColor {return shift-> colorIndex( ci::HiliteText , @_)};
sub light3DColor {return shift-> colorIndex( ci::Light3DColor, @_)};
sub popupFont {($#_)?$_[0]-> set_popup_font ($_[1]) :return Prima::Font-> new($_[0], "get_popup_font", "set_popup_font")}
sub popupColor { return shift-> popupColorIndex( ci::NormalText , @_)};
sub popupBackColor { return shift-> popupColorIndex( ci::Normal , @_)};
sub popupDisabledBackColor{ return shift-> popupColorIndex( ci::Disabled , @_)};
sub popupHiliteBackColor { return shift-> popupColorIndex( ci::Hilite , @_)};
sub popupDisabledColor { return shift-> popupColorIndex( ci::DisabledText, @_)};
sub popupHiliteColor { return shift-> popupColorIndex( ci::HiliteText , @_)};
sub popupDark3DColor { return shift-> popupColorIndex( ci::Dark3DColor , @_)};
sub popupLight3DColor { return shift-> popupColorIndex( ci::Light3DColor, @_)};
sub x_centered {($#_)?$_[0]-> set_centered(1,0) :$_[0]-> raise_wo("x_centered"); }
sub y_centered {($#_)?$_[0]-> set_centered(0,1) :$_[0]-> raise_wo("y_centered"); }
sub hint
{
return $_[0]->get_hint unless $#_;
$_[0]->set_hint( (( ref($_[1]) // '') eq 'SCALAR') ? $_[0]->_parse_markup(hint => $_[1]) : $_[1] );
}
sub text
{
return $_[0]->get_text unless $#_;
$_[0]->set_text( (( ref($_[1]) // '') eq 'SCALAR') ? $_[0]->_parse_markup(text => $_[1]) : $_[1] );
}
sub insert
{
my $self = shift;
my @e;
while (ref $_[0]) {
my $cl = shift @{$_[0]};
$cl = "Prima::$cl"
unless $cl =~ /^Prima::/ || $cl-> isa("Prima::Component");
push @e, $cl-> create(@{$_[0]}, owner=> $self);
shift;
}
if (@_) {
my $cl = shift @_;
$cl = "Prima::$cl"
unless $cl =~ /^Prima::/ || $cl-> isa("Prima::Component");
push @e, $cl-> create(@_, owner=> $self);
}
return wantarray ? @e : $e[0];
}
# The help context string is a pod-styled link ( see perlpod ) :
# "file/section". If the widget's helpContext begins with /,
# it's clearly a sub-topic, and the leading content is to be
# extracted up from the hierarchy. When a grouping widget
# does not have any help file related to, and does not wish that
# its childrens' helpContext would be combined with the upper
# helpContext, an empty string " " can be set
sub help
{
my $self = $_[0];
my $ht = $self-> helpContext;
return 0 if $ht =~ /^\s+$/;
if ( length($ht) && $ht !~ m[^/]) {
$::application-> open_help( $ht);
return 1;
}
my $file;
while ( $self = $self-> owner) {
my $ho = $self-> helpContext;
return 0 if $ho =~ /^\s+$/;
if ( length($ht) && $ht !~ /^\//) {
$file = $ht;
last;
( run in 0.622 second using v1.01-cache-2.11-cpan-364913b4093 )