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