1
2#  Created by:
3#     Anton Berezin  <tobez@tobez.org>
4#     Dmitry Karasik <dmitry@karasik.eu.org>
5#
6package Prima::Classes;
7use strict;
8use warnings;
9use Prima;
10use Prima::Const;
11
12package Prima::array;
13use base 'Tie::Array';
14use Carp;
15
16sub new
17{
18	my ($class, $letter, $buf) = @_;
19	die "bad array type" if $letter !~ /^[idSs]$/;
20	my @tie;
21	my @push;
22	my $size = length pack $letter, 0;
23	if ( defined $buf ) {
24		if ( ref $buf ) {
25			croak "$buf is not an array" unless ref $buf eq 'ARRAY';
26			@push = @$buf;
27			$buf = '';
28		} else {
29			croak "Bad length ". length($buf). ", must be mod $size" if length($buf) % $size;
30		}
31	} else {
32		$buf = '';
33	}
34	tie @tie, $class, $buf, $size, $letter;
35	push @tie, @push if @push;
36	return \@tie;
37}
38
39sub new_short  { shift->new('s', @_) }
40sub new_ushort { shift->new('S', @_) }
41sub new_int    { shift->new('i', @_) }
42sub new_double { shift->new('d', @_) }
43
44use constant REF  => 0;
45use constant SIZE => 1;
46use constant PACK => 2;
47
48sub is_array { ((ref tied @{$_[0]}) // '') eq 'Prima::array' }
49
50sub substr
51{
52	my ( $self, $offset, $length, $replacement) = @_;
53	my $a1 = tied @$self;
54	my $len = length($a1->[REF]) / $a1->[SIZE];
55	croak "offset beyond array boundaries" if $offset > $len || -$offset > $len;
56	my $newref;
57	if ( defined $replacement ) {
58		croak "bad length" if $length < 0;
59		croak "bad array" unless is_array($replacement);
60		my $a2 = tied @$replacement;
61		croak "replacement of type '$a2->[PACK]' is incompatible with type '$a1->[PACK]'"
62			if $a1->[PACK] ne $a2->[PACK];
63		$newref = CORE::substr( $a1->[REF], $offset * $a1->[SIZE], $length * $a1->[SIZE], $a2->[REF]);
64	} elsif ( defined $length ) {
65		$newref = CORE::substr( $a1->[REF], $offset * $a1->[SIZE], $length * $a1->[SIZE]);
66	} else {
67		$newref = CORE::substr( $a1->[REF], $offset * $a1->[SIZE]);
68	}
69	return ref($a1)->new( $a1->[PACK], $newref );
70}
71
72sub append
73{
74	croak "bad array" if grep { !is_array($_) } @_;
75	my ( $a1, $a2 ) = map { tied @$_ } @_;
76	croak "bad array type='$a2->[PACK]', expected '$a1->[PACK]'" if $a1->[PACK] ne $a2->[PACK];
77	$a1->[REF] .= $a2->[REF];
78}
79
80sub clone
81{
82	my $self = tied @{$_[0]};
83	my ( $buf, $size, $pack ) = @$self;
84	return __PACKAGE__->new($pack, $buf);
85}
86
87sub TIEARRAY  { bless \@_, shift }
88sub FETCH     { unpack( $_[0]->[PACK], CORE::substr( $_[0]->[REF], $_[1] * $_[0]->[SIZE], $_[0]->[SIZE] )) }
89sub STORE     { CORE::substr( $_[0]->[REF], $_[1] * $_[0]->[SIZE], $_[0]->[SIZE], pack( $_[0]->[PACK], $_[2] )) }
90sub FETCHSIZE { length( $_[0]->[REF] ) / $_[0]->[SIZE] }
91sub EXISTS    { $_[1] < FETCHSIZE($_[0]) }
92sub EXTEND    { $_[0]->[REF] .= "\x0" x ($_[1] * $_[0]->[SIZE] - length $_[0]->[REF]) }
93sub STORESIZE {
94	( $_[1] > FETCHSIZE($_[0]) ) ?
95		(STORE($_[0], $_[1] - 1, 0)) :
96		(CORE::substr( $_[0]->[REF], $_[1] * $_[0]->[SIZE] ) = '' )
97}
98sub DELETE    { warn "This array does not implement delete functionality" }
99
100package Prima::rect;
101
102sub new       { bless [$#_ ? (($#_ == 4) ? @_[1..$#_] : (0,0,@_[1,2])) : (0,0,0,0)], $_[0] }
103sub new_box   { bless [@_[1,2], $_[1] + $_[3] + 1, $_[2] + $_[4] + 1], $_[0] }
104sub clone     { bless [@{$_[0]}], ref $_[0] }
105sub is_empty  { $_[0]->[0] == $_[0]->[2] && $_[0]->[1] == $_[0]->[3] }
106sub origin    { $_[0]->[0], $_[0]->[1] }
107sub size      { $_[0]->[2] - $_[0]->[0] - 1, $_[0]->[3] - $_[0]->[1] - 1 }
108sub box       { $_[0]->[0], $_[0]->[1], $_[0]->[2] - $_[0]->[0] - 1, $_[0]->[3] - $_[0]->[1] - 1 }
109sub inclusive { $_[0]->[0], $_[0]->[1], $_[0]->[2] - 1, $_[0]->[3] - 1 }
110
111sub is_equal
112{
113	my ( $x, $y ) = @_;
114	if ( $x-> is_empty ) {
115		return $y->is_empty;
116	} elsif ( $y-> is_empty ) {
117		return 0;
118	} else {
119		return
120			$x->[0] == $y->[0] &&
121			$x->[1] == $y->[1] &&
122			$x->[2] == $y->[2] &&
123			$x->[3] == $y->[3];
124	}
125}
126
127sub union
128{
129	my ( $x, $y ) = @_;
130	return $y->clone if $x->is_empty;
131	return $x->clone if $y->is_empty;
132
133	$x = $x->clone;
134	$x->[0] = $y->[0] if $x->[0] > $y->[0];
135	$x->[1] = $y->[1] if $x->[1] > $y->[1];
136	$x->[2] = $y->[2] if $x->[2] < $y->[2];
137	$x->[3] = $y->[3] if $x->[3] < $y->[3];
138	return $x;
139}
140
141sub intersect
142{
143	my ( $x, $y ) = @_;
144	return ref($x)->new if
145		$x->is_empty or
146		$y->is_empty or
147		$x->[0] > $y->[2] or
148		$x->[2] < $y->[0] or
149		$x->[1] > $y->[3] or
150		$x->[3] < $y->[1]
151		;
152
153	$x = $x->clone;
154	$x->[0] = $y->[0] if $x->[0] > $y->[0];
155	$x->[1] = $y->[1] if $x->[1] > $y->[1];
156	$x->[2] = $y->[2] if $x->[2] < $y->[2];
157	$x->[3] = $y->[3] if $x->[3] < $y->[3];
158	return $x;
159}
160
161sub enlarge
162{
163	my ( $x, $d ) = @_;
164	return ref($x)->new if $x->is_empty;
165	$x = $x->clone;
166	$x->[$_] -= $d     for 0,1;
167	$x->[$_] += 2 * $d for 2,3;
168	return $x;
169}
170
171sub shrink { $_[0]->enlarge( -$_[1] ) }
172
173# class Object; base class of all Prima classes
174package Prima::Object;
175use vars qw(@hooks);
176use Carp;
177
178sub CLONE_SKIP { 1 }
179
180sub new { shift-> create(@_) }
181
182sub CREATE
183{
184	my $class = shift;
185	my $self = {};
186	bless( $self, $class);
187	return $self;
188}
189
190sub DESTROY
191{
192	my $self = shift;
193	my $class = ref( $self);
194	::destroy_mate( $self);
195}
196
197sub profile_add
198{
199	my ($self,$profile) = @_;
200	my $default  = $_[0]-> profile_default;
201	$_-> ( $self, $profile, $default) for @hooks;
202	$self-> profile_check_in( $profile, $default);
203	delete @$default{keys %$profile};
204	@$profile{keys %$default}=values %$default;
205	delete $profile-> {__ORDER__};
206	$profile-> {__ORDER__} = [keys %$profile];
207#	%$profile = (%$default, %$profile);
208}
209
210sub profile_default
211{
212	return {};
213}
214
215sub profile_check_in {};
216
217sub raise_ro { croak "Attempt to write read-only property \"$_[1]\""; }
218sub raise_wo { croak "Attempt to read write-only property \"$_[1]\""; }
219
220sub set {
221	for ( my $i = 1; $i < @_; $i += 2) {
222		my $sub_set = $_[$i];
223		$_[0]-> $sub_set( $_[$i+1]);
224	}
225	return;
226}
227
228sub get
229{
230	my $self = shift;
231	map {
232		my @val = $self-> $_();
233		$_ => ((1 == @val) ? $val[0] : \@val)
234	} @_;
235}
236
237package Prima::Font;
238
239sub new
240{
241	my $class = shift;
242	my $self = { OWNER=>shift, READ=>shift, WRITE=>shift};
243	bless( $self, $class);
244	my ($o,$r,$w) = @{$self}{"OWNER","READ","WRITE"};
245	my $f = $o-> $r();
246	$self-> update($f);
247	return $self;
248}
249
250sub update
251{
252	my ( $self, $f) = @_;
253	for ( keys %{$f}) { $self-> {$_} = $f-> {$_}; }
254}
255
256sub set
257{
258	my ($o,$r,$w) = @{$_[0]}{"OWNER","READ","WRITE"};
259	my ($self, %pr) = @_;
260	$self-> update( \%pr);
261	$o-> $w( \%pr);
262}
263
264for ( qw( size name width height direction style pitch encoding vector)) {
265	eval <<GENPROC;
266   sub $_
267   {
268      my (\$o,\$r,\$w) = \@{\$_[0]}{"OWNER","READ","WRITE"};
269      my \$font = \$#_ ? {$_ => \$_[1]} : \$o->\$r();
270      return \$#_ ? (\$_[0]->update(\$font), \$o->\$w(\$font)) : \$font->{$_};
271   }
272GENPROC
273}
274
275for ( qw( ascent descent family weight maximalWidth internalLeading externalLeading
276	xDeviceRes yDeviceRes firstChar lastChar breakChar defaultChar
277)) {
278	eval <<GENPROC;
279   sub $_
280   {
281      my (\$o,\$r) = \@{\$_[0]}{"OWNER","READ"};
282      my \$font = \$o->\$r();
283      return \$#_ ? Prima::Object-> raise_ro("Font::$_") : \$font->{$_};
284   }
285GENPROC
286}
287
288
289sub DESTROY {}
290
291package Prima::Component;
292use vars qw(@ISA);
293@ISA = qw(Prima::Object);
294
295{
296my %RNT = (
297	ChangeOwner => nt::Default,
298	ChildEnter  => nt::Default,
299	ChildLeave  => nt::Default,
300	Create      => nt::Default,
301	Destroy     => nt::Default,
302	PostMessage => nt::Default,
303);
304
305sub notification_types { return \%RNT; }
306}
307
308sub profile_default
309{
310	my $def = $_[ 0]-> SUPER::profile_default;
311	my %prf = (
312		name        => ref $_[ 0],
313		owner       => $::application,
314		delegations => undef,
315	);
316	@$def{keys %prf} = values %prf;
317	return $def;
318}
319
320sub profile_check_in
321{
322	my ( $self, $p, $default) = @_;
323	my $owner = $p-> {owner} ? $p-> {owner} : $default-> {owner};
324	$self-> SUPER::profile_check_in( $p, $default);
325	if (
326		defined $owner
327		and !exists( $p-> {name})
328		and $default-> {name} eq ref $self
329	) {
330		$p-> {name} = ( ref $self) .  (
331			1 + map {
332				(ref $self) eq (ref $_) ? 1 : ()
333			} $owner-> get_components
334		);
335		$p-> { name} =~ s/(.*):([^:]+)$/$2/;
336	}
337}
338
339sub get_notify_sub
340{
341	my ($self, $note) = @_;
342	my $rnt = $self-> notification_types-> {$note};
343	$rnt = nt::Default unless defined $rnt;
344	if ( $rnt & nt::CustomFirst) {
345		my ( $referer, $sub, $id) = $self-> get_notification(
346			$note,
347			($rnt & nt::FluxReverse) ? -1 : 0
348		);
349		if ( defined $referer) {
350			return $sub, $referer, $self if $referer != $self;
351			return $sub, $self;
352		}
353		my $method = "on_" . lc $note;
354		return ( $sub, $self) if $sub = $self-> can( $method);
355	} else {
356		my ( $sub, $method) = ( undef, "on_" . lc $note);
357		return ( $sub, $self) if $sub = $self-> can( $method);
358		my ( $referer, $sub2, $id) = $self-> get_notification( $note, ($rnt & nt::FluxReverse) ? -1 : 0);
359		if ( defined $referer) {
360			return ( $sub, $referer, $self) if $referer != $self;
361			return ( $sub, $self);
362		}
363	}
364	return undef;
365}
366
367sub AUTOLOAD
368{
369	no strict;
370	my $self = shift;
371	my $expectedMethod = $AUTOLOAD;
372	Carp::confess "There is no such thing as \"$expectedMethod\"\n"
373		if scalar(@_) or not ref $self;
374	my ($componentName) = $expectedMethod =~ /::([^:]+)$/;
375	my $component = $self-> bring( $componentName);
376	Carp::confess("Unknown widget or method \"$expectedMethod\"")
377		unless $component && ref($component);
378	return $component;
379}
380
381sub find_component
382{
383	my ( $self, $name ) = @_;
384	my @q = $self-> get_components;
385	while ( my $x = shift @q ) {
386		return $x if $x-> name eq $name;
387		push @q, $x-> get_components;
388	}
389	return undef;
390}
391
392package Prima::File;
393use vars qw(@ISA);
394@ISA = qw(Prima::Component);
395
396{
397my %RNT = (
398	%{Prima::Component-> notification_types()},
399	Read        => nt::Default,
400	Write       => nt::Default,
401	Exception   => nt::Default,
402);
403
404sub notification_types { return \%RNT; }
405}
406
407sub profile_default
408{
409	my $def = $_[ 0]-> SUPER::profile_default;
410	my %prf = (
411		file  => undef,
412		fd    => -1,
413		mask  => fe::Read | fe::Write | fe::Exception,
414		owner => undef,
415	);
416	@$def{keys %prf} = values %prf;
417	return $def;
418}
419
420sub profile_check_in
421{
422	my ( $self, $p, $default) = @_;
423	$p->{fd} = fileno($p->{file}) if exists $p->{file} && ! exists $p->{fd};
424}
425
426package Prima::Clipboard;
427use vars qw(@ISA);
428@ISA = qw(Prima::Component);
429
430sub profile_default
431{
432	my $def = $_[ 0]-> SUPER::profile_default;
433	$def-> {name} = 'Clipboard';
434	return $def;
435}
436
437sub has_format
438{
439	my ( $self, $format ) = @_;
440	$self-> open;
441	my $exists = 0;
442	$::application-> notify( 'FormatExists', $format, $self, \$exists );
443	$self-> close;
444	return $exists ? 1 : 0;
445}
446
447sub copy
448{
449	my ( $self, $format, $data, $keep ) = @_;
450	$self-> open;
451	$self-> clear unless $keep;
452	$::application-> notify( 'Copy', $format, $self, $data );
453	$self-> close;
454}
455
456sub paste
457{
458	my ( $self, $format ) = @_;
459	my $data;
460	$::application-> notify( 'Paste', $format, $_[0], \$data);
461	return $data;
462}
463
464sub text  { $#_ ? shift->copy('Text',  @_) : $_[0]->paste('Text') }
465sub image { $#_ ? shift->copy('Image', @_) : $_[0]->paste('Image') }
466
467package Prima::Region;
468use vars qw(@ISA);
469@ISA = qw(Prima::Component);
470
471sub origin { (shift->box)[0,1] }
472sub size   { (shift->box)[2,3] }
473sub rect
474{
475	my @box = shift->box;
476	return @box[0,1], $box[0] + $box[2], $box[1] + $box[3];
477}
478
479sub dup
480{
481	my $r = ref($_[0])->new;
482	$r->combine($_[0], rgnop::Copy);
483	return $r;
484}
485
486sub bitmap_or_image
487{
488	my ($self, $class, %param) = @_;
489	return undef if $self-> is_empty;
490	my @box = $self->box;
491	my @size = @box[2,3];
492
493	my $with_offset = delete $param{with_offset};
494	if ( $with_offset ) {
495		$size[0] += $box[0];
496		$size[1] += $box[1];
497	}
498	my $dbm = $class->new( size => \@size, %param);
499	$dbm-> clear;
500	$self-> offset( -$box[0], -$box[1]) unless $with_offset;
501	$dbm-> region($self);
502	$self-> offset( $box[0], $box[1]) unless $with_offset;
503	$dbm-> bar(0,0,@size);
504	return $dbm;
505}
506
507sub bitmap { shift->bitmap_or_image( 'Prima::DeviceBitmap', type => dbt::Bitmap, @_ ) }
508sub image  { shift->bitmap_or_image( 'Prima::Image',        type => im::BW,      @_ ) }
509
510package Prima::Drawable;
511use vars qw(@ISA);
512@ISA = qw(Prima::Component);
513use Prima::Drawable::Basic;
514
515sub profile_default
516{
517	my $def = $_[ 0]-> SUPER::profile_default;
518	my %prf = (
519		alpha           => 0xff,
520		antialias       => 0,
521		color           => cl::Black,
522		backColor       => cl::White,
523		fillMode        => fm::Overlay|fm::Alternate,
524		fillPattern     => fp::Solid,
525		fillPatternOffset => [0,0],
526		font            => {
527			height      => 16,
528			width       => 0,
529			pitch       => fp::Default,
530			style       => fs::Normal,
531			direction   => 0,
532			vector      => fv::Default,
533			name        => "Default",
534			encoding    => "",
535		},
536		lineEnd         => le::Round,
537		lineJoin        => lj::Round,
538		linePattern     => lp::Solid,
539		lineWidth       => 0,
540		miterLimit      => 10.0,
541		owner           => undef,
542		palette         => [],
543		region          => undef,
544		rop             => rop::CopyPut,
545		rop2            => rop::NoOper,
546		textOutBaseline => 0,
547		textOpaque      => 0,
548		translate       => [ 0, 0],
549	);
550	@$def{keys %prf} = values %prf;
551	return $def;
552}
553
554sub profile_check_in
555{
556	my ( $self, $p, $default) = @_;
557	$self-> SUPER::profile_check_in( $p, $default);
558	$p-> { font} = {} unless exists $p-> { font};
559	$p-> { font} = Prima::Drawable-> font_match( $p-> { font}, $default-> { font});
560	$p->{fillMode} = ( delete($p->{fillWinding}) ? fm::Winding : fm::Alternate) | fm::Overlay
561		if exists $p->{fillWinding} && ! exists $p->{fillMode}; # compatibility
562}
563
564sub font
565{
566	($#_) ?
567		$_[0]-> set_font( $#_ > 1 ?
568			{@_[1 .. $#_]} :
569			$_[1]
570		) :
571		return Prima::Font-> new(
572			$_[0], "get_font", "set_font"
573		)
574}
575
576sub put_image
577{
578	$_[0]-> put_image_indirect(
579		@_[3,1,2], 0, 0,
580		($_[3]-> size) x 2,
581		defined ($_[4]) ? $_[4] : $_[0]-> rop
582	) if $_[3]
583}
584
585sub stretch_image {
586	$_[0]-> put_image_indirect(
587		@_[5,1,2], 0, 0,
588		@_[3,4], $_[5]-> size,
589		defined ($_[6]) ? $_[6] : $_[0]-> rop
590	) if $_[5]
591}
592
593sub has_alpha_layer { 0 }
594
595sub spline
596{
597	my $self = shift;
598	$self->polyline( $self->render_spline(@_) );
599}
600
601sub fill_spline
602{
603	my $self = shift;
604	$self->fillpoly( $self->render_spline(@_) );
605}
606
607sub fillWinding # compatibility
608{
609	return $_[0]->fillMode & fm::Winding unless $#_;
610	$_[0]->fillMode(($_[1] ? fm::Winding : fm::Alternate) | fm::Overlay);
611}
612
613package Prima::Image;
614use vars qw( @ISA);
615@ISA = qw(Prima::Drawable);
616
617{
618my %RNT = (
619	%{Prima::Drawable-> notification_types()},
620	HeaderReady => nt::Default,
621	DataReady   => nt::Default,
622);
623
624sub notification_types { return \%RNT; }
625}
626
627sub profile_default
628{
629	my $def = $_[ 0]-> SUPER::profile_default;
630	my %prf = (
631		conversion    => ict::Optimized,
632		data          => '',
633		height        => 0,
634		scaling       => ist::Box,
635		palette       => [0, 0, 0, 0xFF, 0xFF, 0xFF],
636		colormap      => undef,
637		preserveType  => 0,
638		rangeLo       => 0,
639		rangeHi       => 1,
640		resolution    => [0, 0],
641		type          => im::Mono,
642		width         => 0,
643	);
644	@$def{keys %prf} = values %prf;
645	return $def;
646}
647
648sub profile_check_in
649{
650	my ( $self, $p, $default) = @_;
651
652	if ( exists $p-> {colormap} and not exists $p-> {palette}) {
653		$p-> {palette} = [ map {
654			( $_        & 0xFF),
655			(($_ >> 8)  & 0xFF),
656			(($_ >> 16) & 0xFF),
657		} @{$p-> {colormap}} ];
658		delete $p-> {colormap};
659	}
660
661	if ( exists $p->{size} ) {
662		$p->{width}  //= $p->{size}->[0];
663		$p->{height} //= $p->{size}->[1];
664	}
665
666	$self-> SUPER::profile_check_in( $p, $default);
667}
668
669sub rangeLo      { return shift-> stats( is::RangeLo , @_); }
670sub rangeHi      { return shift-> stats( is::RangeHi , @_); }
671sub sum          { return shift-> stats( is::Sum     , @_); }
672sub sum2         { return shift-> stats( is::Sum2    , @_); }
673sub mean         { return shift-> stats( is::Mean    , @_); }
674sub variance     { return shift-> stats( is::Variance, @_); }
675sub stdDev       { return shift-> stats( is::StdDev  , @_); }
676
677sub colormap
678{
679	if ( $#_) {
680		shift-> palette([ map {
681			( $_        & 0xFF),
682			(($_ >> 8)  & 0xFF),
683			(($_ >> 16) & 0xFF),
684		} @_ ]);
685	} else {
686		my $p = $_[0]-> palette;
687		my ($i,@r);
688		for ($i = 0; $i < @$p; $i += 3) {
689			push @r, $$p[$i] + ($$p[$i+1] << 8) + ($$p[$i+2] << 16);
690		}
691		return @r;
692	}
693}
694
695sub clone
696{
697	my $i = shift->dup;
698	$i->set(@_);
699	return $i;
700}
701
702sub ui_scale
703{
704	my ($self, %opt) = @_;
705
706	my $zoom = delete($opt{zoom}) // ( $::application ? $::application->uiScaling : 1 );
707	return $self if $zoom == 1.0;
708
709	my $scaling = delete($opt{scaling}) // ist::Quadratic;
710	$self->set(
711		%opt,
712		scaling => $scaling,
713		size => [ map { $_ * $zoom } $self->size ],
714	);
715	return $self;
716}
717
718sub to_region { Prima::Region->new( image => shift ) }
719
720sub shear { $_[0]->transform(1,@_[2,1],1) }
721
722package Prima::Icon;
723use vars qw( @ISA);
724@ISA = qw(Prima::Image);
725
726sub profile_default
727{
728	my $def = $_[ 0]-> SUPER::profile_default;
729	my %prf = (
730		autoMasking => am::Auto,
731		mask        => '',
732		maskType    => im::bpp1,
733		maskColor   => 0,
734		maskIndex   => 0,
735	);
736	@$def{keys %prf} = values %prf;
737	return $def;
738}
739
740sub profile_check_in
741{
742	my ( $self, $p, $default) = @_;
743
744	if ( exists $p-> {mask} and not exists $p-> {autoMasking}) {
745		$p-> {autoMasking} = am::None;
746	}
747	$self-> SUPER::profile_check_in( $p, $default);
748}
749
750sub maskLineSize { int(( $_[0]->width * $_[0]->maskType + 31 ) / 32 ) * 4 }
751
752sub mirror
753{
754        my ($self, $vertically) = @_;
755        my ($xor, $and) = $self->split;
756        $and->preserveType(1);
757        $_->mirror($vertically) for $xor, $and;
758        $self->combine($xor, $and);
759}
760
761sub create_combined
762{
763	my $self = shift->new( autoMasking => am::None );
764	$self->combine(@_);
765	return $self;
766}
767
768sub has_alpha_layer { shift->maskType == im::bpp8 }
769
770sub ui_scale
771{
772	my ($self, %opt) = @_;
773
774	my $zoom = delete($opt{zoom}) // ( $::application ? $::application->uiScaling : 1 );
775	return $self if $zoom == 1.0;
776
777	my $argb    = delete($opt{argb})    // ($::application ? $::application-> get_system_value( sv::LayeredWidgets ) : 0);
778	my $scaling = delete($opt{scaling}) // ($argb ? ist::Quadratic : ist::Box );
779
780	if ( $scaling <= ist::Box ) {
781		# don't uglify bitmaps with box scaling where zoom is 1.25 or 2.75
782		$zoom = int($zoom + .5);
783		return $self if $zoom <= 1.0;
784	}
785
786	$self->set(
787		%opt,
788		scaling => $scaling,
789		size => [ map { $_ * $zoom } $self->size ],
790	);
791
792	return $self;
793}
794
795sub image
796{
797	my ($self,%opt) = @_;
798	my ($image, undef) = $self-> split;
799	$image->backColor($opt{background} // 0);
800	$image->clear;
801	$image->put_image(0,0,$self,rop::CopyPut);
802	return $image;
803}
804
805package Prima::DeviceBitmap;
806use vars qw( @ISA);
807@ISA = qw(Prima::Drawable);
808
809sub profile_default
810{
811	my $def = $_[ 0]-> SUPER::profile_default;
812	my %prf = (
813		height       => 0,
814		width        => 0,
815		type         => dbt::Pixmap,
816		monochrome   => undef, # back-compat
817	);
818	@$def{keys %prf} = values %prf;
819	return $def;
820}
821
822sub profile_check_in
823{
824	my ( $self, $p, $default) = @_;
825
826	if ( exists $p-> {monochrome} and not exists $p-> {type}) {
827		$p-> {type} = $p->{monochrome} ? dbt::Bitmap : dbt::Pixmap;
828	}
829	if ( exists $p->{size} ) {
830		$p->{width}  //= $p->{size}->[0];
831		$p->{height} //= $p->{size}->[1];
832	}
833	$self-> SUPER::profile_check_in( $p, $default);
834}
835
836sub has_alpha_layer { shift->type == dbt::Layered }
837
838sub dup
839{
840	my $self = shift;
841	my $dup = ref($self)->new(
842		size => [ $self->size ],
843		type => $self->type
844	);
845	$dup->backColor(0);
846	$dup->clear;
847	$dup->put_image(0,0,$self,rop::SrcOver);
848	return $dup;
849}
850
851package Prima::Timer;
852use vars qw(@ISA);
853@ISA = qw(Prima::Component);
854
855{
856my %RNT = (
857	%{Prima::Component-> notification_types()},
858	Tick => nt::Default,
859);
860
861sub notification_types { return \%RNT; }
862}
863
864sub profile_default
865{
866	my $def = $_[ 0]-> SUPER::profile_default;
867	my %prf = (
868		timeout => 1000,
869	);
870	@$def{keys %prf} = values %prf;
871	return $def;
872}
873
874sub toggle { $_[0]->get_active ? $_[0]->stop : $_[0]->start }
875
876package Prima::Printer;
877use vars qw(@ISA);
878@ISA = qw(Prima::Drawable);
879
880sub profile_default
881{
882	my $def = $_[ 0]-> SUPER::profile_default;
883	my %prf = (
884		printer => '',
885		owner   => $::application,
886	);
887	@$def{keys %prf} = values %prf;
888	return $def;
889}
890
891package Prima::Widget;
892use vars qw(@ISA %WidgetProfile @default_font_box);
893@ISA = qw(Prima::Drawable);
894
895{
896my %RNT = (
897	%{Prima::Drawable-> notification_types()},
898	Change         => nt::Default,
899	Click          => nt::Default,
900	Close          => nt::Command,
901	ColorChanged   => nt::Default,
902	Disable        => nt::Default,
903	DragBegin      => nt::Command,
904	DragOver       => nt::Command,
905	DragEnd        => nt::Command,
906	DragQuery      => nt::Command,
907	DragResponse   => nt::Command,
908	Enable         => nt::Default,
909	Enter          => nt::Default,
910	FontChanged    => nt::Default,
911	Hide           => nt::Default,
912	Hint           => nt::Default,
913	KeyDown        => nt::Command,
914	KeyUp          => nt::Command,
915	Leave          => nt::Default,
916	Menu           => nt::Default,
917	MouseClick     => nt::Command,
918	MouseDown      => nt::Command,
919	MouseUp        => nt::Command,
920	MouseMove      => nt::Command,
921	MouseWheel     => nt::Command,
922	MouseEnter     => nt::Command,
923	MouseLeave     => nt::Command,
924	Move           => nt::Default,
925	Paint          => nt::Action,
926	Popup          => nt::Command,
927	Setup          => nt::Default,
928	Show           => nt::Default,
929	Size           => nt::Default,
930	TranslateAccel => nt::Default,
931	SysHandle      => nt::Default,
932	ZOrderChanged  => nt::Default,
933);
934
935sub notification_types { return \%RNT; }
936}
937
938%WidgetProfile = (
939	accelTable        => undef,
940	accelItems        => undef,
941	autoEnableChildren=> 0,
942	backColor         => cl::Normal,
943	briefKeys         => 1,
944	buffered          => 0,
945	clipChildren      => 1,
946	capture           => 0,
947	clipOwner         => 1,
948	color             => cl::NormalText,
949	bottom            => 100,
950	centered          => 0,
951	current           => 0,
952	currentWidget     => undef,
953	cursorVisible     => 0,
954	dark3DColor       => cl::Dark3DColor,
955	disabledBackColor => cl::Disabled,
956	disabledColor     => cl::DisabledText,
957	dndAware          => 0,
958	enabled           => 1,
959	firstClick        => 1,
960	focused           => 0,
961	geometry          => gt::GrowMode,
962	growMode          => 0,
963	height            => 100,
964	helpContext       => '',
965	hiliteBackColor   => cl::Hilite,
966	hiliteColor       => cl::HiliteText,
967	hint              => '',
968	hintVisible       => 0,
969	layered           => 0,
970	light3DColor      => cl::Light3DColor,
971	left              => 100,
972	ownerColor        => 0,
973	ownerBackColor    => 0,
974	ownerFont         => 1,
975	ownerHint         => 1,
976	ownerShowHint     => 1,
977	ownerPalette      => 1,
978	packInfo          => undef,
979	packPropagate     => 1,
980	placeInfo         => undef,
981	pointerIcon       => undef,
982	pointer           => cr::Default,
983	pointerType       => cr::Default,
984	popup             => undef,
985	popupColor             => cl::NormalText,
986	popupBackColor         => cl::Normal,
987	popupHiliteColor       => cl::HiliteText,
988	popupHiliteBackColor   => cl::Hilite,
989	popupDisabledColor     => cl::DisabledText,
990	popupDisabledBackColor => cl::Disabled,
991	popupLight3DColor      => cl::Light3DColor,
992	popupDark3DColor       => cl::Dark3DColor,
993	popupItems        => undef,
994	right             => 200,
995	scaleChildren     => 1,
996	selectable        => 0,
997	selected          => 0,
998	selectedWidget    => undef,
999	selectingButtons  => mb::Left,
1000	shape             => undef,
1001	showHint          => 1,
1002	syncPaint         => 0,
1003	tabOrder          => -1,
1004	tabStop           => 1,
1005	text              => undef,
1006	textOutBaseline   => 0,
1007	top               => 200,
1008	transparent       => 0,
1009	visible           => 1,
1010	widgetClass       => wc::Custom,
1011	widgets           => undef,
1012	width             => 100,
1013	x_centered        => 0,
1014	y_centered        => 0,
1015);
1016
1017my $_markup_loaded;
1018sub _markup($)
1019{
1020	unless ( $_markup_loaded ) {
1021		eval "use Prima::Drawable::Markup;";
1022		die $@ if $@;
1023		$_markup_loaded++;
1024	}
1025	return Prima::Drawable::Markup::M( ${ $_[0] } );
1026}
1027
1028sub profile_default
1029{
1030	my $def = $_[ 0]-> SUPER::profile_default;
1031
1032	@$def{keys %WidgetProfile} = values %WidgetProfile;
1033
1034	my %WidgetProfile = (
1035		# secondary; contains anonymous arrays that must be generated at every invocation
1036		cursorPos         => [ 0, 0],
1037		cursorSize        => [ 12, 3],
1038		designScale       => [ 0, 0],
1039		origin            => [ 0, 0],
1040		owner             => $::application,
1041		pointerHotSpot    => [ 0, 0],
1042		rect              => [ 0, 0, 100, 100],
1043		size              => [ 100, 100],
1044		sizeMin           => [ 0, 0],
1045		sizeMax           => [ 16384, 16384],
1046	);
1047	@$def{keys %WidgetProfile} = values %WidgetProfile;
1048	@$def{qw( font popupFont)} = ( $_[ 0]-> get_default_font, $_[ 0]-> get_default_popup_font);
1049	return $def;
1050}
1051
1052sub profile_check_in
1053{
1054	my ( $self, $p, $default) = @_;
1055	my $orgFont = exists $p-> { font} ? $p-> { font} : undef;
1056	my $owner = exists $p-> { owner} ? $p-> { owner} : $default-> { owner};
1057	$self-> SUPER::profile_check_in( $p, $default);
1058	delete $p-> { font} unless defined $orgFont;
1059
1060	for my $tx ( qw(text hint)) {
1061		$p->{$tx} = _markup $p->{$tx} if defined $p->{$tx} && (ref($p->{$tx}) // '') eq 'SCALAR';
1062	}
1063
1064	my $name = defined $p-> {name} ? $p-> {name} : $default-> {name};
1065	$p-> {text} = $name
1066		if !defined $p-> { text} and !defined $default-> {text};
1067
1068	$p-> {showHint} = 1 if
1069		( defined $owner) &&
1070		( defined $::application) &&
1071		( $owner == $::application) &&
1072		( exists $p-> { ownerShowHint} ?
1073			$p-> { ownerShowHint} :
1074			$default-> { ownerShowHint}
1075		);
1076
1077	$p-> {enabled} = $owner-> enabled
1078		if defined $owner && $owner-> autoEnableChildren;
1079
1080	(my $cls = ref $self) =~ s/^Prima:://;
1081
1082	for my $fore (qw(color hiliteBackColor disabledColor dark3DColor)) {
1083		unless (exists $p-> {$fore}) {
1084			my $clr = Prima::Widget::fetch_resource(
1085				$cls, $name, 'Foreground',
1086				$fore, $owner, fr::Color
1087			);
1088			$p-> {$fore} = $clr if defined $clr;
1089		}
1090	}
1091	for my $back (qw(backColor hiliteColor disabledBackColor light3DColor)) {
1092		unless (exists $p-> {$back}) {
1093			my $clr = Prima::Widget::fetch_resource(
1094				$cls, $name, 'Background',
1095				$back, $owner, fr::Color
1096			);
1097			$p-> {$back} = $clr if defined $clr;
1098		}
1099	}
1100	for my $fon (qw(font popupFont)) {
1101		my $f = Prima::Widget::fetch_resource(
1102			$cls, $name, 'Font', $fon, $owner, fr::Font);
1103		next unless defined $f;
1104		unless ( exists $p-> {$fon}) {
1105			$p-> {$fon} = $f;
1106		} else {
1107			for ( keys %$f) {
1108				$p-> {$fon}-> {$_} = $$f{$_}
1109					unless exists $p-> {$fon}-> {$_};
1110			}
1111		}
1112	}
1113
1114	for ( $owner ? qw( color backColor showHint hint font): ()) {
1115		my $o_ = 'owner' . ucfirst $_;
1116		$p-> { $_} = $owner-> $_() if
1117			( $p-> { $o_} = exists $p-> { $_} ? 0 :
1118				( exists $p-> { $o_} ? $p-> { $o_} : $default-> {$o_}));
1119	}
1120	for ( qw( font popupFont)) {
1121		$p-> { $_} = {} unless exists $p-> { $_};
1122		$p-> { $_} = Prima::Widget-> font_match( $p-> { $_}, $default-> { $_});
1123	}
1124
1125	if ( exists( $p-> { origin})) {
1126		$p-> { left  } = $p-> { origin}-> [ 0];
1127		$p-> { bottom} = $p-> { origin}-> [ 1];
1128	}
1129
1130	if ( exists( $p-> { rect})) {
1131		my $r = $p-> { rect};
1132		$p-> { left  } = $r-> [ 0];
1133		$p-> { bottom} = $r-> [ 1];
1134		$p-> { right } = $r-> [ 2];
1135		$p-> { top   } = $r-> [ 3];
1136	}
1137
1138	if ( exists( $p-> { size})) {
1139		$p-> { width } = $p-> { size}-> [ 0];
1140		$p-> { height} = $p-> { size}-> [ 1];
1141	}
1142
1143	my $designScale = exists $p-> {designScale} ? $p-> {designScale} : $default-> {designScale};
1144	if ( defined $designScale) {
1145		my @defScale = @$designScale;
1146		if (( $defScale[0] > 0) && ( $defScale[1] > 0)) {
1147			@{$p-> { designScale}} = @defScale;
1148			for ( qw ( left right top bottom width height)) {
1149				$p-> {$_} = $default-> {$_}
1150					unless exists $p-> {$_};
1151			}
1152		} else {
1153			@defScale = $owner-> designScale
1154				if defined $owner && $owner-> scaleChildren;
1155			@{$p-> { designScale}} = @defScale
1156				if ( $defScale[0] > 0) && ( $defScale[1] > 0);
1157		}
1158		if ( exists $p-> { designScale}) {
1159			my @d = @{$p-> { designScale}};
1160			unless ( @default_font_box) {
1161				my $f = $::application-> get_default_font;
1162				@default_font_box = ( $f-> { width}, $f-> { height});
1163			}
1164			my @a = @default_font_box;
1165			$p-> {left}    *= $a[0] / $d[0] if exists $p-> {left};
1166			$p-> {right}   *= $a[0] / $d[0] if exists $p-> {right};
1167			$p-> {top}     *= $a[1] / $d[1] if exists $p-> {top};
1168			$p-> {bottom}  *= $a[1] / $d[1] if exists $p-> {bottom};
1169			$p-> {width}   *= $a[0] / $d[0] if exists $p-> {width};
1170			$p-> {height}  *= $a[1] / $d[1] if exists $p-> {height};
1171		}
1172	} else {
1173		$p-> {designScale} = [0,0];
1174	}
1175
1176
1177	$p-> { top} = $default-> { bottom} + $p-> { height}
1178		if ( !exists ( $p-> { top}) && !exists( $p-> { bottom}) && exists( $p-> { height}));
1179	$p-> { height} = $p-> { top} - $p-> { bottom}
1180		if ( !exists( $p-> { height}) && exists( $p-> { top}) && exists( $p-> { bottom}));
1181	$p-> { top} = $p-> { bottom} + $p-> { height}
1182		if ( !exists( $p-> { top}) && exists( $p-> { height}) && exists( $p-> { bottom}));
1183	$p-> { bottom} = $p-> { top} - $p-> { height}
1184		if ( !exists( $p-> { bottom}) && exists( $p-> { height}) && exists( $p-> { top}));
1185	$p-> { bottom} = $p-> { top} - $default-> { height}
1186		if ( !exists( $p-> { bottom}) && !exists( $p-> { height}) && exists( $p-> { top}));
1187	$p-> { top} = $p-> { bottom} + $default-> { height}
1188		if ( !exists( $p-> { top}) && !exists( $p-> { height}) && exists( $p-> { bottom}));
1189
1190
1191	$p-> { right} = $default-> { left} + $p-> { width}
1192		if ( !exists( $p-> { right}) && !exists( $p-> { left}) && exists( $p-> { width}));
1193	$p-> { width} = $p-> { right} - $p-> { left}
1194		if ( !exists( $p-> { width}) && exists( $p-> { right}) && exists( $p-> { left}));
1195	$p-> { right} = $p-> { left} + $p-> { width}
1196		if ( !exists( $p-> { right}) && exists( $p-> { width}) && exists( $p-> { left}));
1197	$p-> { left}  = $p-> { right} - $p-> { width}
1198		if ( !exists( $p-> { left}) && exists( $p-> { right}) && exists( $p-> { width}));
1199	$p-> { left}  = $p-> { right} - $default-> {width}
1200		if ( !exists( $p-> { left}) && !exists( $p-> { width}) && exists($p-> {right}));
1201	$p-> { right} = $p-> { left} + $default-> { width}
1202		if ( !exists( $p-> { right}) && !exists( $p-> { width}) && exists( $p-> { left}));
1203
1204	if ( $p-> { popup}) {
1205		$p-> { popupItems} = $p-> {popup}-> get_items('');
1206		delete $p-> {popup};
1207	}
1208
1209	my $current = exists $p-> { current} ? $p-> { current} : $default-> { current};
1210	if ( defined($owner) && !$current && !$owner-> currentWidget) {
1211		my $e = exists $p-> { enabled} ? $p-> { enabled} : $default-> { enabled};
1212		my $v = exists $p-> { visible} ? $p-> { visible} : $default-> { visible};
1213		$p-> {current} = 1 if $e && $v;
1214	}
1215
1216	if ( exists $p-> {pointer}) {
1217		my $pt = $p-> {pointer};
1218		$p-> {pointerType}    = ( ref($pt) ? cr::User : $pt)
1219			if !exists $p-> {pointerType};
1220		$p-> {pointerIcon}    = $pt
1221			if !exists $p-> {pointerIcon} && ref( $pt);
1222		$p-> {pointerHotSpot} = $pt-> {__pointerHotSpot}
1223			if !exists $p-> {pointerHotSpot} && ref( $pt) && exists $pt-> {__pointerHotSpot};
1224	}
1225
1226	if ( exists $p-> {pack}) {
1227		for ( keys %{$p-> {pack}}) {
1228			s/^-//; # Tk syntax
1229			$p-> {packInfo}-> {$_} = $p-> {pack}-> {$_}
1230				unless exists $p-> {packInfo}-> {$_};
1231		}
1232		$p-> {geometry} = gt::Pack unless exists $p-> {geometry};
1233	}
1234	$p-> {packPropagate} = 0 if !exists $p-> {packPropagate} &&
1235		( exists $p-> {width} || exists $p-> {height});
1236
1237	if ( exists $p-> {place}) {
1238		for ( keys %{$p-> {place}}) {
1239			s/^-//; # Tk syntax
1240			$p-> {placeInfo}-> {$_} = $p-> {place}-> {$_}
1241				unless exists $p-> {placeInfo}-> {$_};
1242		}
1243		$p-> {geometry} = gt::Place unless exists $p-> {geometry};
1244	}
1245}
1246
1247sub capture               {($#_)?shift-> set_capture     (@_)   :return $_[0]-> get_capture;     }
1248sub centered              {($#_)?$_[0]-> set_centered(1,1)      :$_[0]-> raise_wo("centered");   }
1249sub dark3DColor           {return shift-> colorIndex( ci::Dark3DColor , @_)};
1250sub disabledBackColor     {return shift-> colorIndex( ci::Disabled    , @_)};
1251sub disabledColor         {return shift-> colorIndex( ci::DisabledText, @_)};
1252sub hiliteBackColor       {return shift-> colorIndex( ci::Hilite      , @_)};
1253sub hiliteColor           {return shift-> colorIndex( ci::HiliteText  , @_)};
1254sub light3DColor          {return shift-> colorIndex( ci::Light3DColor, @_)};
1255sub popupFont             {($#_)?$_[0]-> set_popup_font ($_[1])  :return Prima::Font-> new($_[0], "get_popup_font", "set_popup_font")}
1256sub popupColor            { return shift-> popupColorIndex( ci::NormalText  , @_)};
1257sub popupBackColor        { return shift-> popupColorIndex( ci::Normal      , @_)};
1258sub popupDisabledBackColor{ return shift-> popupColorIndex( ci::Disabled    , @_)};
1259sub popupHiliteBackColor  { return shift-> popupColorIndex( ci::Hilite      , @_)};
1260sub popupDisabledColor    { return shift-> popupColorIndex( ci::DisabledText, @_)};
1261sub popupHiliteColor      { return shift-> popupColorIndex( ci::HiliteText  , @_)};
1262sub popupDark3DColor      { return shift-> popupColorIndex( ci::Dark3DColor , @_)};
1263sub popupLight3DColor     { return shift-> popupColorIndex( ci::Light3DColor, @_)};
1264
1265sub x_centered       {($#_)?$_[0]-> set_centered(1,0)      :$_[0]-> raise_wo("x_centered"); }
1266sub y_centered       {($#_)?$_[0]-> set_centered(0,1)      :$_[0]-> raise_wo("y_centered"); }
1267
1268sub hint
1269{
1270	return $_[0]->get_hint unless $#_;
1271	$_[0]->set_hint( (( ref($_[1]) // '') eq 'SCALAR') ? _markup $_[1] : $_[1] );
1272}
1273
1274sub text
1275{
1276	return $_[0]->get_text unless $#_;
1277	$_[0]->set_text( (( ref($_[1]) // '') eq 'SCALAR') ? _markup $_[1] : $_[1] );
1278}
1279
1280sub insert
1281{
1282	my $self = shift;
1283	my @e;
1284	while (ref $_[0]) {
1285		my $cl = shift @{$_[0]};
1286		$cl = "Prima::$cl"
1287			unless $cl =~ /^Prima::/ || $cl-> isa("Prima::Component");
1288		push @e, $cl-> create(@{$_[0]}, owner=> $self);
1289		shift;
1290	}
1291	if (@_) {
1292		my $cl = shift @_;
1293		$cl = "Prima::$cl"
1294			unless $cl =~ /^Prima::/ || $cl-> isa("Prima::Component");
1295		push @e, $cl-> create(@_, owner=> $self);
1296	}
1297	return wantarray ? @e : $e[0];
1298}
1299
1300#  The help context string is a pod-styled link ( see perlpod ) :
1301#  "file/section". If the widget's helpContext begins with /,
1302#  it's clearly a sub-topic, and the leading content is to be
1303#  extracted up from the hierarchy. When a grouping widget
1304#  does not have any help file related to, and does not wish that
1305#  its childrens' helpContext would be combined with the upper
1306#  helpContext, an empty string " " can be set
1307
1308sub help
1309{
1310	my $self = $_[0];
1311	my $ht = $self-> helpContext;
1312	return 0 if $ht =~ /^\s+$/;
1313	if ( length($ht) && $ht !~ m[^/]) {
1314		$::application-> open_help( $ht);
1315		return 1;
1316	}
1317	my $file;
1318	while ( $self = $self-> owner) {
1319		my $ho = $self-> helpContext;
1320		return 0 if $ho =~ /^\s+$/;
1321		if ( length($ht) && $ht !~ /^\//) {
1322			$file = $ht;
1323			last;
1324		}
1325	}
1326	return 0 unless defined $file;
1327	$file .= '/' unless $file =~ /\/$/;
1328	$::application-> open_help( $file . $ht);
1329}
1330
1331sub pointer
1332{
1333	if ( $#_) {
1334		$_[0]-> pointerType( $_[1]), return unless ref( $_[1]);
1335		defined $_[1]-> {__pointerHotSpot} ?
1336			$_[0]-> set(
1337				pointerIcon    => $_[1],
1338				pointerHotSpot => $_[1]-> {__pointerHotSpot},
1339			) :
1340			$_[0]-> pointerIcon( $_[1]);
1341		$_[0]-> pointerType( cr::User);
1342	} else {
1343		my $i = $_[0]-> pointerType;
1344		return $i if $i != cr::User;
1345		$i = $_[0]-> pointerIcon;
1346		$i-> {__pointerHotSpot} = [ $_[0]-> pointerHotSpot];
1347		return $i;
1348	}
1349}
1350
1351sub widgets
1352{
1353	return shift-> get_widgets unless $#_;
1354	my $self = shift;
1355	return unless $_[0];
1356	$self-> insert(($#_ or ref($_[0]) ne 'ARRAY') ? @_ : @{$_[0]});
1357}
1358
1359sub key_up      { splice( @_,5,0,1) if $#_ > 4; shift-> key_event( cm::KeyUp, @_)}
1360sub key_down    { shift-> key_event( cm::KeyDown, @_)}
1361sub mouse_up    { splice( @_,5,0,0) if $#_ > 4; shift-> mouse_event( cm::MouseUp, @_); }
1362sub mouse_move  { splice( @_,5,0,0) if $#_ > 4; splice( @_,1,0,0); shift-> mouse_event( cm::MouseMove, @_) }
1363sub mouse_enter { splice( @_,5,0,0) if $#_ > 4; splice( @_,1,0,0); shift-> mouse_event( cm::MouseEnter, @_) }
1364sub mouse_leave { shift-> mouse_event( cm::MouseLeave ) }
1365sub mouse_wheel { splice( @_,5,0,0) if $#_ > 4; shift-> mouse_event( cm::MouseWheel, @_) }
1366sub mouse_down  { splice( @_,5,0,0) if $#_ > 4;
1367						splice( @_,2,0,0) if $#_ < 4;
1368						shift-> mouse_event( cm::MouseDown, @_);}
1369sub mouse_click { shift-> mouse_event( cm::MouseClick, @_) }
1370sub select      { $_[0]-> selected(1); }
1371sub deselect    { $_[0]-> selected(0); }
1372sub focus       { $_[0]-> focused(1); }
1373sub defocus     { $_[0]-> focused(0); }
1374
1375# Tk namespace and syntax compatibility
1376
1377sub __tk_dash_map
1378{
1379	my %ret;
1380	my %hash = @_;
1381	while ( my ( $k, $v ) = each %hash ) {
1382		$k =~ s/^-//;
1383		$ret{$k} = $v;
1384	}
1385	return %ret;
1386}
1387
1388sub pack {
1389	my $self = shift;
1390	$self-> packInfo( { __tk_dash_map(@_) });
1391	$self-> geometry( gt::Pack);
1392}
1393
1394sub place {
1395	my $self = shift;
1396	$self-> placeInfo( { __tk_dash_map(@_) });
1397	$self-> geometry( gt::Place);
1398}
1399
1400sub packForget { $_[0]-> geometry( gt::Default) if $_[0]-> geometry == gt::Pack }
1401sub placeForget { $_[0]-> geometry( gt::Default) if $_[0]-> geometry == gt::Place }
1402sub packSlaves { shift-> get_pack_slaves()}
1403sub placeSlaves { shift-> get_place_slaves()}
1404
1405sub rect_bevel
1406{
1407	my ( $self, $canvas, $x, $y, $x1, $y1, %opt) = @_;
1408
1409	my $width = $opt{width} || 0;
1410	my @c3d   = ( $opt{concave} || $opt{panel}) ?
1411		( $self-> dark3DColor, $self-> light3DColor) :
1412		( $self-> light3DColor, $self-> dark3DColor);
1413	my $fill  = $opt{fill};
1414
1415	return $canvas-> rect3d( $x, $y, $x1, $y1, $width, @c3d, $fill)
1416		if $width < 2;
1417
1418	# 0 - upper left under 2 -- inner square
1419	# 1 - lower right over 3
1420	# 2 - upper left         -- outer square
1421	# 3 - lower right
1422	if ( $opt{concave}) {
1423		push @c3d, 0x404040, $c3d[0];
1424	} elsif ( $opt{panel}) {
1425		@c3d = ( 0x404040, $self-> disabledBackColor, $c3d[0], $c3d[1]);
1426	} else {
1427		push @c3d, $c3d[1], 0x404040;
1428	}
1429
1430	$fill = $fill->clone( widgetClass => $self->widgetClass ) if $fill && ref($fill);
1431
1432	my $hw = int( $width / 2);
1433	$canvas-> rect3d( $x, $y, $x1, $y1, $hw, @c3d[2,3], $fill);
1434	$canvas-> rect3d( $x + $hw, $y + $hw, $x1 - $hw, $y1 - $hw, $width - $hw, @c3d[0,1]);
1435}
1436
1437sub has_alpha_layer { $_[0]-> layered && $_[0]-> is_surface_layered }
1438
1439sub begin_drag
1440{
1441	my ( $self, @opt ) = @_;
1442	my %opt;
1443	if ( 1 != @opt ) {
1444		%opt = @opt;
1445	} elsif ( ref($opt[0]) && $opt[0]->isa('Prima::Image')) {
1446		$opt{image} = $opt[0];
1447	} else {
1448		$opt{text} = $opt[0];
1449	}
1450
1451	my $actions = ($opt{actions} // dnd::Copy) & dnd::Mask;
1452	unless ( $actions ) {
1453		Carp::carp("bad actions");
1454		return -1;
1455	}
1456
1457	# don't start dragging immediately
1458	if ( $opt{track} // 1 ) {
1459		my @start_pos = $self->pointerPos;
1460		my $offset = $opt{track} // 5;
1461		my $break  = 0;
1462		my @id;
1463		push @id, $self-> add_notification( MouseMove => sub {
1464			my ( undef, undef, $x, $y ) = @_;
1465			$break = 1 if
1466				abs( $start_pos[0] - $x ) > $offset ||
1467				abs( $start_pos[1] - $y ) > $offset;
1468		});
1469		push @id,
1470			map { $self-> add_notification( $_ => sub { $break = -1 }) }
1471			qw(MouseLeave MouseClick MouseDown MouseUp Destroy);
1472		1 while !$break && $::application->yield(1);
1473		return dnd::None unless $self->alive;
1474		$self->remove_notification($_) for @id;
1475		return -1 if $break < 0;
1476	}
1477
1478	# data
1479	my $clipboard = $::application->get_dnd_clipboard;
1480	if ( exists $opt{text}) {
1481		$clipboard->text($opt{text});
1482		$opt{preview} //= $opt{text};
1483	} elsif ( exists $opt{image}) {
1484		$clipboard->image($opt{image});
1485		$opt{preview} //= $opt{image};
1486	} elsif ( exists $opt{format} and exists $opt{data}) {
1487		$clipboard->copy($opt{format}, $opt{data});
1488	} # or else you fill the clipboard yourself
1489
1490	my @id;
1491	my %pointers;
1492	my $last_action = -1;
1493	$opt{preview} = undef unless $::application->get_system_value(sv::ColorPointer);
1494
1495	my @max = map { $_ / 8 } $::application->size;
1496	if ( $opt{preview} && !ref($opt{preview}) ) {
1497		my @lines = split "\n", $opt{preview};
1498		my $fh    = $self->font->height;
1499		my @sz = ( 0, 10 + $fh * @lines );
1500		for my $text ( @lines ) {
1501			my $tw = $self->get_text_shape_width($text, 1);
1502			$sz[0] = $tw if $sz[0] < $tw;
1503		}
1504		$sz[0] += 10;
1505		$sz[0] = $max[0] if $sz[0] > $max[0];
1506		$sz[1] = $max[1] if $sz[1] > $max[1];
1507		my $i = Prima::Icon->new(
1508			size      => \@sz,
1509			type      => im::RGB,
1510			color     => $self->color,
1511			backColor => $self->backColor,
1512			font      => $self->font,
1513			autoMasking => am::None,
1514			maskType    => im::bpp8,
1515		);
1516		$i->begin_paint;
1517		$i->clear;
1518		my $y = $i->height - $fh - 5;
1519		for my $text ( @lines ) {
1520			$i->text_shape_out( $text, 5, $y);
1521			$y -= $fh;
1522		}
1523		$i->end_paint;
1524		$i->bar_alpha(160, 0, 0, $i->size);
1525		$opt{preview} = $i;
1526	}
1527
1528	if ( my $p = $opt{preview}) {
1529		my @sz = $p->size;
1530		$opt{preview} = $p->extract(0, 0,
1531			($sz[0] > $max[0]) ? $max[0] : $sz[0],
1532			($sz[1] > $max[1]) ? $max[1] : $sz[1],
1533		) if $sz[0] > $max[0] || $sz[1] > $max[1];
1534	}
1535
1536	# select multi actions
1537	unless (dnd::is_one_action($actions)) {
1538		my $default_action = dnd::to_one_action($actions);
1539		push @id, $self-> add_notification( DragQuery => sub {
1540			my ( $self, $modmap, $counterpart, $ref ) = @_;
1541			if ( $modmap & km::Ctrl and $actions & dnd::Move ) {
1542				$ref->{action} = dnd::Move;
1543			} elsif ( $modmap & km::Shift and $actions & dnd::Link ) {
1544				$ref->{action} = dnd::Link;
1545			} else {
1546				$ref->{action} = $default_action;
1547			}
1548		});
1549	}
1550
1551	# update pointers
1552	push @id, $self-> add_notification( DragResponse => sub {
1553		my ( undef, $allow, $action, $counterpart ) = @_;
1554
1555		unless ($pointers{$action}) {
1556			$self->pointer(dnd::pointer($action));
1557			my $p = $opt{preview};
1558			my $i = $self->pointerIcon;
1559			my @hs = $self->pointerHotSpot;
1560			$hs[1] += $p->height;
1561			my $n = Prima::Icon->new(
1562				type     => im::RGB,
1563				maskType => im::bpp8,
1564				autoMasking => am::None,
1565				size     => [ $i->width + $p->width, $i-> height + $p-> height ],
1566			);
1567			$i->autoMasking(am::None);
1568			$i->type(im::RGB);
1569			$i->maskType(8);
1570			$p->maskType(8)
1571				if $p->isa('Prima::Icon');
1572			$n->put_image( 0, $p->height, $i, rop::SrcCopy);
1573			$n->put_image( $i->width, 0, $p, rop::SrcCopy);
1574			$n->bar_alpha(0xff, $i->width, 0, $i->width + $p->width - 1, $p->height - 1)
1575				if !$p->isa('Prima::Icon');
1576			$n->{__pointerHotSpot} = \@hs;
1577			$pointers{$action} = $n;
1578		}
1579		if ($action != $last_action) {
1580			$last_action = $action;
1581			$self->pointer($pointers{$action});
1582		}
1583	}) if $opt{preview};
1584
1585	my $old_dndAware;
1586	if ( !( $opt{self_aware} // 1) ) {
1587		$old_dndAware = $self->dndAware;
1588		$self->dndAware(0);
1589	}
1590	my $pointer = $self->pointer;
1591	my @opp = $::application->pointerPos;
1592	my ($ret, $counterpart) = $self->dnd_start($actions, !$opt{preview});
1593	if ( $self->alive ) {
1594		if ( $ret == dnd::None && $opt{preview} ) {
1595			my @npp = $::application->pointerPos;
1596			$npp[1] -= $opt{preview}->height;
1597			my $paint_flag = 0;
1598			my $flyback = Prima::Widget->new(
1599				size      => [ $opt{preview}->size ],
1600				origin    => \@npp,
1601				layered   => 1,
1602				backColor => 0,
1603				syncPaint => 1,
1604				onPaint   => sub {
1605					$_[0]->clear;
1606					$_[0]->put_image(0,0,$opt{preview});
1607					$paint_flag = 1;
1608				}
1609			);
1610			$flyback-> insert( Timer =>
1611				onTick => sub {
1612					$flyback->destroy if $flyback;
1613					undef $flyback;
1614				},
1615				timeout => 1000,
1616			)-> start;
1617			$flyback->bring_to_front;
1618			my @targ = map { $_ / 2 } $flyback->size;
1619			while (abs( $npp[0] - $opp[0]) > $targ[0] || abs($npp[1] - $opp[1]) > $targ[1]) {
1620				@npp = map { ( $npp[$_] + $opp[$_] ) / 2 } 0, 1;
1621				my $max_wait = 10;
1622				$::application->yield while !$paint_flag && $max_wait--;
1623				last unless $flyback;
1624				$paint_flag = 0;
1625				CORE::select(undef, undef, undef, 0.1);
1626				$flyback->origin(@npp);
1627				$flyback->bring_to_front;
1628			}
1629			$flyback->destroy if $flyback;
1630			undef $flyback;
1631		}
1632		$self->pointer($pointer); # dnd_start doesn't affect children pointers and doesn't restore them
1633		$self->remove_notification($_) for @id;
1634		$self->dndAware($old_dndAware) if $old_dndAware;
1635	}
1636	return wantarray ? ($ret, $counterpart) : $ret;
1637}
1638
1639package Prima::Window;
1640use vars qw(@ISA);
1641@ISA = qw(Prima::Widget);
1642
1643{
1644my %RNT = (
1645	%{Prima::Widget-> notification_types()},
1646	Activate      => nt::Default,
1647	Deactivate    => nt::Default,
1648	EndModal      => nt::Default,
1649	Execute       => nt::Default,
1650	WindowState   => nt::Default,
1651);
1652
1653sub notification_types { return \%RNT; }
1654}
1655
1656sub profile_default
1657{
1658	my $def = $_[ 0]-> SUPER::profile_default;
1659	my %prf = (
1660		borderIcons           => bi::All,
1661		borderStyle           => bs::Sizeable,
1662		clipOwner             => 0,
1663		growMode              => gm::DontCare,
1664		effects               => undef,
1665		icon                  => 0,
1666		mainWindow            => 0,
1667		menu                  => undef,
1668		menuItems             => undef,
1669		menuColor             => cl::NormalText,
1670		menuBackColor         => cl::Normal,
1671		menuHiliteColor       => cl::HiliteText,
1672		menuHiliteBackColor   => cl::Hilite,
1673		menuDisabledColor     => cl::DisabledText,
1674		menuDisabledBackColor => cl::Disabled,
1675		menuLight3DColor      => cl::Light3DColor,
1676		menuDark3DColor       => cl::Dark3DColor,
1677		menuFont              => $_[ 0]-> get_default_menu_font,
1678		modalResult           => mb::Cancel,
1679		modalHorizon          => 1,
1680		onTop                 => 0,
1681		ownerIcon             => 1,
1682		originDontCare        => 1,
1683		sizeDontCare          => 1,
1684		tabStop               => 0,
1685		taskListed            => 1,
1686		transparent           => 0,
1687		widgetClass           => wc::Window,
1688		windowState           => ws::Normal,
1689	);
1690	@$def{keys %prf} = values %prf;
1691	return $def;
1692}
1693
1694sub profile_check_in
1695{
1696	my ( $self, $p, $default) = @_;
1697
1698	my $shp = exists $p-> {originDontCare} ? $p-> {originDontCare} : $default-> {originDontCare};
1699	my $shs = exists $p-> {sizeDontCare  } ? $p-> {sizeDontCare  } : $default-> {sizeDontCare  };
1700	$p-> {originDontCare} = 0 if $shp and
1701		exists $p-> {left}   or exists $p-> {bottom} or
1702		exists $p-> {origin} or exists $p-> {rect} or
1703		exists $p-> {top}    or exists $p-> {right};
1704	$p-> {sizeDontCare} = 0 if $shs and
1705		exists $p-> {width}  or exists $p-> {height} or
1706		exists $p-> {size}   or exists $p-> {rect} or
1707		exists $p-> {right}  or exists $p-> {top};
1708
1709	$self-> SUPER::profile_check_in( $p, $default);
1710
1711	if ( $p-> { menu}) {
1712		$p-> { menuItems} = $p-> {menu}-> get_items("");
1713		delete $p-> {menu};
1714	}
1715	$p-> { menuFont} = {}
1716		unless exists $p-> { menuFont};
1717	$p-> { menuFont} = Prima::Drawable-> font_match( $p-> { menuFont}, $default-> { menuFont});
1718
1719	$p-> { modalHorizon} = 0
1720		if $p-> {clipOwner} || $default-> {clipOwner};
1721
1722	$p-> { growMode} = 0
1723		if !exists $p-> {growMode}
1724		and $default-> {growMode} == gm::DontCare
1725		and (
1726			( exists $p-> {clipOwner} && ($p-> {clipOwner}==1))
1727			or ( $default-> {clipOwner} == 1)
1728		);
1729
1730	my $owner = exists $p-> { owner} ? $p-> { owner} : $default-> { owner};
1731	if ( $owner) {
1732		$p-> {icon} = $owner-> icon if
1733			( $p-> {ownerIcon} = exists $p-> {icon} ?
1734				0 :
1735				( exists $p-> {ownerIcon} ?
1736					$p-> {ownerIcon} :
1737					$default-> {ownerIcon}
1738				)
1739			);
1740	}
1741}
1742
1743sub maximize    { $_[0]-> windowState( ws::Maximized)}
1744sub minimize    { $_[0]-> windowState( ws::Minimized)}
1745sub restore     { $_[0]-> windowState( ws::Normal)}
1746
1747sub frameWidth           {($#_)?$_[0]-> frameSize($_[1], ($_[0]-> frameSize)[1]):return ($_[0]-> frameSize)[0];  }
1748sub frameHeight          {($#_)?$_[0]-> frameSize(($_[0]-> frameSize)[0], $_[1]):return ($_[0]-> frameSize)[1];  }
1749sub menuFont             {($#_)?$_[0]-> menuFont   ($_[1])  :return Prima::Font-> new($_[0], "get_menu_font", "set_menu_font")}
1750sub menuColor            { return shift-> menuColorIndex( ci::NormalText   , @_);}
1751sub menuBackColor        { return shift-> menuColorIndex( ci::Normal       , @_);}
1752sub menuDisabledBackColor{ return shift-> menuColorIndex( ci::Disabled     , @_);}
1753sub menuHiliteBackColor  { return shift-> menuColorIndex( ci::Hilite       , @_);}
1754sub menuDisabledColor    { return shift-> menuColorIndex( ci::DisabledText , @_);}
1755sub menuHiliteColor      { return shift-> menuColorIndex( ci::HiliteText   , @_);}
1756sub menuDark3DColor      { return shift-> menuColorIndex( ci::Dark3DColor  , @_);}
1757sub menuLight3DColor     { return shift-> menuColorIndex( ci::Light3DColor , @_);}
1758
1759
1760package Prima::Dialog;
1761use vars qw(@ISA);
1762@ISA = qw(Prima::Window);
1763
1764sub profile_default
1765{
1766	my $def = $_[ 0]-> SUPER::profile_default;
1767	my %prf = (
1768		borderStyle    => bs::Dialog,
1769		borderIcons    => bi::SystemMenu | bi::TitleBar,
1770		widgetClass    => wc::Dialog,
1771		originDontCare => 0,
1772		sizeDontCare   => 0,
1773		taskListed     => 0,
1774	);
1775	@$def{keys %prf} = values %prf;
1776	return $def;
1777}
1778
1779package Prima::MainWindow;
1780use vars qw(@ISA);
1781@ISA = qw(Prima::Window);
1782
1783sub profile_default
1784{
1785	my $def = $_[ 0]-> SUPER::profile_default;
1786	my %prf = (
1787		mainWindow => 1,
1788	);
1789	@$def{keys %prf} = values %prf;
1790	return $def;
1791}
1792
1793sub on_create  { $::main_window = $_[0] }
1794sub on_destroy { $::application-> close; undef $::main_window }
1795
1796package Prima::MenuItem;
1797
1798sub create
1799{
1800	my $class = $_[0];
1801	my $self = {};
1802	bless( $self, $class);
1803	$self-> {menu} = $_[1];
1804	$self-> {id}   = $_[2];
1805	return $self;
1806}
1807
1808sub new { shift-> create(@_) }
1809sub menu    { $_[0]->{menu} }
1810
1811sub accel   { my $self = shift;return $self-> {menu}-> accel( $self-> {id}, @_);}
1812sub action  { my $self = shift;return $self-> {menu}-> action ( $self-> {id}, @_);}
1813sub autoToggle { my $self = shift;return $self-> {menu}-> autoToggle( $self-> {id}, @_);}
1814sub checked { my $self = shift;return $self-> {menu}-> checked( $self-> {id}, @_);}
1815sub enabled { my $self = shift;return $self-> {menu}-> enabled( $self-> {id}, @_);}
1816sub options { my $self = shift;return $self-> {menu}-> options( $self-> {id}, @_);}
1817sub image   { my $self = shift;return $self-> {menu}-> image  ( $self-> {id}, @_);}
1818sub icon    { my $self = shift;return $self-> {menu}-> icon   ( $self-> {id}, @_);}
1819sub key     { my $self = shift;return $self-> {menu}-> key    ( $self-> {id}, @_);}
1820sub submenu { my $self = shift;return $self-> {menu}-> submenu( $self-> {id}, @_);}
1821sub text    { my $self = shift;return $self-> {menu}-> text   ( $self-> {id}, @_);}
1822sub group   { my $self = shift;return $self-> {menu}-> group  ( $self-> {id}, @_);}
1823sub items   { my $i = shift; ( @_) ? $i-> { menu}-> set_items  ( $i-> { id}, @_):return $i-> {menu}-> get_items  ( $i-> { id}); }
1824sub enable  { $_[0]-> {menu}-> enabled( $_[0]-> { id}, 1) };
1825sub disable { $_[0]-> {menu}-> enabled( $_[0]-> { id}, 0) };
1826sub check   { $_[0]-> {menu}-> checked( $_[0]-> { id}, 1) };
1827sub uncheck { $_[0]-> {menu}-> checked( $_[0]-> { id}, 0) };
1828sub remove  { $_[ 0]-> {menu}-> remove( $_[0]-> { id}) }
1829sub toggle  {
1830	my $i = !$_[0]-> { menu}-> checked($_[0]-> { id});
1831	$_[0]-> { menu}-> checked($_[0]-> { id}, $i);
1832	return $i
1833}
1834sub id {
1835	return $_[0]->{id} unless $#_;
1836	$_[0]->menu->set_variable( $_[0]->{id}, $_[1] );
1837	$_[0]->{id} = $_[1];
1838}
1839sub execute  { $_[0]->{menu}->execute($_[0]->{id}) }
1840sub children { $_[0]->{menu}->get_children($_[0]->{id}) }
1841sub is_separator { $_[0]->{menu}->is_separator($_[0]->{id}) }
1842sub is_submenu   { $_[0]->{menu}->is_submenu($_[0]->{id}) }
1843
1844sub check_icon_size { $::application->get_system_value(sv::MenuCheckSize) }
1845
1846package Prima::AbstractMenu;
1847use vars qw(@ISA);
1848@ISA = qw(Prima::Component);
1849
1850{
1851my %RNT = (
1852	%{Prima::Component-> notification_types()},
1853	Change      => nt::Default,
1854	ItemMeasure => nt::Action,
1855	ItemPaint   => nt::Action,
1856);
1857
1858sub notification_types { return \%RNT; }
1859}
1860
1861sub profile_default
1862{
1863	my $def = $_[ 0]-> SUPER::profile_default;
1864	my %prf = (
1865		selected => 1,
1866		items    => undef
1867	);
1868	@$def{keys %prf} = values %prf;
1869	return $def;
1870}
1871
1872sub select     {$_[0]-> selected(1)}
1873
1874sub enable     {$_[0]-> enabled($_[1],1);}
1875sub disable    {$_[0]-> enabled($_[1],0);}
1876sub check      {$_[0]-> checked($_[1],1);}
1877sub uncheck    {$_[0]-> checked($_[1],0);}
1878sub items      {($#_)?$_[0]-> set_items       ($_[1]):return $_[0]-> get_items("");      }
1879sub toggle     {
1880	my $i = !$_[0]-> checked($_[1]);
1881	$_[0]-> checked($_[1], $i);
1882	return $i;
1883}
1884
1885sub AUTOLOAD
1886{
1887	no strict;
1888	my $self = shift;
1889	my $expectedMethod = $AUTOLOAD;
1890	die "There is no such method as \"$expectedMethod\""
1891		if scalar(@_) or not ref $self;
1892	my ($itemName) = $expectedMethod =~ /::([^:]+)$/;
1893	die "Unknown menu item identifier \"$itemName\""
1894		unless defined $itemName && $self-> has_item( $itemName);
1895	return Prima::MenuItem-> create( $self, $itemName);
1896}
1897sub on_itemmeasure
1898{
1899	my ( $self, $id, $ref) = @_;
1900	my $opt = $self->options($id) or return;
1901	return if ref($opt) ne 'HASH';
1902	if ( defined( my $cb = $opt->{onMeasure})) {
1903		$cb->($self, Prima::MenuItem->new($self, $id), $ref);
1904		$self->clear_event;
1905	}
1906}
1907
1908sub on_itempaint
1909{
1910	my ( $self, $id, @r) = @_;
1911	my $opt = $self->options($id) or return;
1912	return if ref($opt) ne 'HASH';
1913	if ( defined( my $cb = $opt->{onPaint})) {
1914		$cb->($self, Prima::MenuItem->new($self, $id), @r);
1915		$self->clear_event;
1916	}
1917}
1918
1919
1920package Prima::AccelTable;
1921use vars qw(@ISA);
1922@ISA = qw(Prima::AbstractMenu);
1923
1924package Prima::Menu;
1925use vars qw(@ISA);
1926@ISA = qw(Prima::AbstractMenu);
1927
1928package Prima::Popup;
1929use vars qw(@ISA);
1930@ISA = qw(Prima::AbstractMenu);
1931
1932sub profile_default
1933{
1934	my $def = $_[ 0]-> SUPER::profile_default;
1935	$def-> {autoPopup} = 1;
1936	return $def;
1937}
1938
1939package Prima::HintWidget;
1940use vars qw(@ISA);
1941@ISA = qw(Prima::Widget);
1942
1943sub profile_default
1944{
1945	my $def = $_[ 0]-> SUPER::profile_default;
1946	my %prf = (
1947		showHint      => 0,
1948		ownerShowHint => 0,
1949		visible       => 0,
1950	);
1951	@$def{keys %prf} = values %prf;
1952	return $def;
1953}
1954
1955sub on_change
1956{
1957	my $self = $_[0];
1958	my @ln = $self->text_split_lines($self->text);
1959	my $maxLn = 0;
1960	for ( @ln) {
1961		my $x = $self-> get_text_width( $_);
1962		$maxLn = $x if $maxLn < $x;
1963	}
1964	$self-> size(
1965		$maxLn + 6,
1966		( $self-> font-> height * scalar @ln) + 2
1967	);
1968}
1969
1970sub on_paint
1971{
1972	my ($self,$canvas) = @_;
1973	my @size = $canvas-> size;
1974	$canvas-> clear( 1, 1, $size[0]-2, $size[1]-2);
1975	$canvas-> rectangle( 0, 0, $size[0]-1, $size[1]-1);
1976	my $fh = $canvas-> font-> height;
1977	my ( $x, $y) = ( 3, $size[1] - 1 - $fh);
1978	my @ln = $canvas->text_split_lines($self->text);
1979	for ( @ln) {
1980		$canvas-> text_shape_out( $_, $x, $y);
1981		$y -= $fh;
1982	}
1983}
1984
1985sub set_text
1986{
1987	my $self = $_[0];
1988	$self-> SUPER::set_text( $_[1]);
1989	$self-> notify( 'Change');
1990	$self-> repaint;
1991}
1992
1993package Prima::Application;
1994use vars qw(@ISA @startupNotifications);
1995@ISA = qw(Prima::Widget);
1996
1997{
1998my %RNT = (
1999	%{Prima::Widget-> notification_types()},
2000	FormatExists => nt::Action,
2001	Clipboard    => nt::Action,
2002	Copy         => nt::Action,
2003	Paste        => nt::Action,
2004	Idle         => nt::Default,
2005);
2006
2007sub notification_types { return \%RNT; }
2008}
2009
2010my $unix = Prima::Application-> get_system_info-> {apc} == apc::Unix;
2011
2012sub profile_default
2013{
2014	my $def  = $_[ 0]-> SUPER::profile_default;
2015	my %prf = (
2016		autoClose      => 0,
2017		pointerType    => cr::Arrow,
2018		pointerVisible => 1,
2019		language       => Prima::Application->get_system_info->{guiLanguage},
2020		icon           => undef,
2021		owner          => undef,
2022		scaleChildren  => 0,
2023		ownerColor     => 0,
2024		ownerBackColor => 0,
2025		ownerFont      => 0,
2026		ownerShowHint  => 0,
2027		ownerPalette   => 0,
2028		showHint       => 1,
2029		hintClass      => 'Prima::HintWidget',
2030		hintColor      => cl::Black,
2031		hintBackColor  => 0xffff80,
2032		hintPause      => 800,
2033		hintFont       => Prima::Widget::get_default_font,
2034		modalHorizon   => 1,
2035		printerClass   => $unix ? 'Prima::PS::Printer' : 'Prima::Printer',
2036		printerModule  => $unix ? 'Prima::PS::Printer' : '',
2037		helpClass      => 'Prima::HelpViewer',
2038		helpModule     => 'Prima::HelpViewer',
2039		textDirection  => 0,
2040		uiScaling      => 0,
2041		wantUnicodeInput => 1,
2042	);
2043	@$def{keys %prf} = values %prf;
2044	return $def;
2045}
2046
2047sub profile_check_in
2048{
2049	my ( $self, $p, $default) = @_;
2050	$p->{textDirection} //= $self->lang_is_rtl($p->{language} // $default->{language});
2051	$self-> SUPER::profile_check_in( $p, $default);
2052	delete $p-> { printerModule};
2053	delete $p-> { owner};
2054	delete $p-> { ownerColor};
2055	delete $p-> { ownerBackColor};
2056	delete $p-> { ownerFont};
2057	delete $p-> { ownerShowHint};
2058	delete $p-> { ownerPalette};
2059}
2060
2061sub add_startup_notification
2062{
2063	shift if ref($_[0]) ne 'CODE'; # skip class reference, if any
2064	if ( $::application) {
2065		$_-> ($::application) for @_;
2066	} else {
2067		push( @startupNotifications, @_);
2068	}
2069}
2070
2071sub setup
2072{
2073	my $self = $::application = shift;
2074	$self-> SUPER::setup;
2075	for my $clp (Prima::Clipboard-> get_standard_clipboards()) {
2076		$self-> {$clp} = $self-> insert( qw(Prima::Clipboard), name => $clp)
2077			unless exists $self-> {$clp};
2078	}
2079	$_-> ($self) for @startupNotifications;
2080	undef @startupNotifications;
2081
2082	# setup image cliboard transfer routines specific to gtk
2083	if ( $unix ) {
2084		my %weights = (
2085			png  => 4,  # png is lossless
2086			bmp  => 3,  # bmp is independent on codecs but huge
2087			tiff => 2,  # tiff is usually lossless
2088		);
2089		my %codecs  = map { lc($_-> {fileShortType})  => $_ } @{Prima::Image-> codecs};
2090		$_->{weight} = $weights{ lc($_-> {fileShortType}) } || 1 for values %codecs;
2091		my @codecs = map { {
2092			mime => "image/$_",
2093			id   => $codecs{$_}->{codecID},
2094			w    => $codecs{$_}->{weight},
2095		} } sort { $codecs{$b}->{weight} <=> $codecs{$a}->{weight} } keys %codecs;
2096		my $clipboard = $self-> Clipboard;
2097		$clipboard-> register_format($_->{mime}) for @codecs;
2098		$self-> {GTKImageClipboardFormats} = \@codecs;
2099	}
2100}
2101
2102sub get_fullscreen_image
2103{
2104	my $self = shift;
2105	if ( $^O eq 'darwin') {
2106		require Prima::sys::XQuartz;
2107		return Prima::sys::XQuartz::get_fullscreen_image($self);
2108	} else {
2109		return $self->get_image(0,0,$self->size);
2110	}
2111}
2112
2113sub get_printer
2114{
2115	unless ( $_[0]-> {Printer}) {
2116		if ( length $_[0]-> {PrinterModule}) {
2117			eval 'use ' . $_[0]-> {PrinterModule} . ';';
2118			die "$@" if $@;
2119		}
2120		$_[0]-> {Printer} = $_[0]-> {PrinterClass}-> create( owner => $_[0], system => 1);
2121	}
2122	return $_[0]-> {Printer};
2123}
2124
2125sub hintFont      {($#_)?$_[0]-> set_hint_font        ($_[1])  :return Prima::Font-> new($_[0], "get_hint_font", "set_hint_font")}
2126sub helpModule    {($#_)?$_[0]-> {HelpModule} = $_[1] : return $_[0]-> {HelpModule}}
2127sub helpClass     {($#_)?$_[0]-> {HelpClass}  = $_[1] : return $_[0]-> {HelpClass}}
2128
2129sub lang_is_rtl
2130{
2131	my $lang = $_[1] // $_[0]->get_system_info->{guiLanguage};
2132	$lang =~ /^(
2133		ar| # arabic
2134		dv| # divehi
2135		fa| # persian (farsi)
2136		ha| # hausa
2137		he| # hebrew
2138		iw| # hebrew (old code)
2139		ji| # yiddish (old code)
2140		ps| # pashto, pushto
2141		ur| # urdu
2142		yi  # yiddish
2143	)/x ? 1 : 0
2144}
2145
2146sub language
2147{
2148	return $_[0]->{language} unless $#_;
2149	my ( $self, $lang ) = @_;
2150	$self->{language} = $lang;
2151	$self->textDirection( $_[0]-> lang_is_rtl($lang));
2152}
2153
2154sub help_init
2155{
2156	return 0 unless length $_[0]-> {HelpModule};
2157	eval 'use ' . $_[0]-> {HelpModule} . ';';
2158	die "$@" if $@;
2159	return 1;
2160}
2161
2162sub close_help
2163{
2164	return '' unless $_[0]-> help_init;
2165	shift-> {HelpClass}-> close;
2166}
2167
2168sub open_help
2169{
2170	my ( $self, $link) = @_;
2171	return unless length $link;
2172	return unless $self-> help_init;
2173	return $self-> {HelpClass}-> open($link);
2174}
2175
2176sub on_clipboard
2177{
2178	my ( $self, $clipboard, $action, $target ) = @_;
2179	if ($clipboard->format_exists('Image')) {
2180		if ( my ( $codec ) = grep { $target eq $_->{mime} } @{ $self-> {GTKImageClipboardFormats} // [] }) {
2181			my ($bits, $handle) = ('');
2182			my $i = $clipboard->fetch('Image') or return;
2183			if (open( $handle, '>', \$bits) and $i->save($handle, codecID => $codec->{id})) {
2184				$clipboard->store($codec->{mime}, $bits);
2185			}
2186		}
2187	}
2188}
2189
2190sub on_copy
2191{
2192	my ( $self, $format, $clipboard, $data ) = @_;
2193	$clipboard-> store( $format, $data);
2194	if ( $format eq 'Image') {
2195		# store(undef) is a special flag for x11 when data can be provided on demand for this format
2196		$clipboard->store($_, undef) for map { $_->{mime} } @{ $self-> {GTKImageClipboardFormats} // [] };
2197	}
2198}
2199
2200sub on_formatexists
2201{
2202	my ( $self, $format, $clipboard, $ref) = @_;
2203
2204	if ( $format eq 'Text') {
2205		if ( $self-> wantUnicodeInput) {
2206			return $$ref = 'UTF8' if $clipboard-> format_exists( 'UTF8');
2207		}
2208		$$ref = $clipboard-> format_exists( $format ) ? $format : undef;
2209	} elsif ( $format eq 'Image') {
2210		$$ref = undef;
2211		return $$ref = 'Image' if $clipboard-> format_exists( 'Image');
2212		my $codecs = $self-> {GTKImageClipboardFormats} or return;
2213		my %formats = map { $_ => 1 } $clipboard-> get_formats;
2214		my @codecs  = grep { $formats{$_->{mime}} } @$codecs or return;
2215		$$ref = $codecs[0]->{mime} if $clipboard-> format_exists($codecs[0]->{mime});
2216	} else {
2217		$$ref = $clipboard-> format_exists( $format ) ? $format : undef;
2218	}
2219	undef;
2220}
2221
2222sub on_paste
2223{
2224	my ( $self, $format, $clipboard, $ref) = @_;
2225
2226	if ( $format eq 'Text') {
2227		if ( $self-> wantUnicodeInput) {
2228			return if defined ( $$ref = $clipboard-> fetch( 'UTF8'));
2229		}
2230		$$ref = $clipboard-> fetch( 'Text');
2231	} elsif ( $format eq 'Image') {
2232		my $codecs  = $self-> {GTKImageClipboardFormats} or goto DEFAULT;
2233		my %formats = map  { $_ => 1 } $clipboard-> get_formats;
2234		my @codecs  = grep { $formats{$_->{mime}} && $_->{w} > 1 } @$codecs or goto DEFAULT;
2235		my $data    = $clipboard-> fetch($codecs[0]->{mime});
2236		return unless defined $data;
2237
2238		my $handle;
2239		open( $handle, '<', \$data) or return;
2240
2241		local $@;
2242		$$ref = Prima::Image-> load($handle, loadExtras => 1 );
2243	} else {
2244	DEFAULT:
2245       		$$ref = $clipboard-> fetch( $format);
2246	}
2247	undef;
2248}
2249
22501;
2251
2252=pod
2253
2254=head1 NAME
2255
2256Prima::Classes - binder module for the built-in classes.
2257
2258=head1 DESCRIPTION
2259
2260C<Prima::Classes> and L<Prima::Const> is a minimal set of perl modules needed for
2261the toolkit. Since the module provides bindings for the core classes, it is required
2262to be included in every Prima-related module and program.
2263
2264=head1 AUTHOR
2265
2266Dmitry Karasik, E<lt>dmitry@karasik.eu.orgE<gt>.
2267
2268=head1 SEE ALSO
2269
2270L<Prima>, L<Prima::Const>
2271
2272
2273=cut
2274
2275