1 | package DC::UI; |
1 | package DC::UI; |
2 | |
2 | |
3 | use utf8; |
3 | use common::sense; |
4 | use strict; |
|
|
5 | |
4 | |
6 | use List::Util (); |
5 | use List::Util (); |
7 | |
6 | |
|
|
7 | use AnyEvent (); |
8 | use Guard (); |
8 | use Guard (); |
9 | |
9 | |
10 | use DC; |
10 | use DC; |
11 | use DC::Pod; |
11 | use DC::Pod; |
12 | use DC::Texture; |
12 | use DC::Texture; |
… | |
… | |
52 | sub get_layout { |
52 | sub get_layout { |
53 | my $layout; |
53 | my $layout; |
54 | |
54 | |
55 | for (grep { $_->{name} } values %WIDGET) { |
55 | for (grep { $_->{name} } values %WIDGET) { |
56 | my $win = $layout->{$_->{name}} = { }; |
56 | my $win = $layout->{$_->{name}} = { }; |
57 | |
57 | |
58 | $win->{x} = ($_->{x} + $_->{w} * 0.5) / $::WIDTH if $_->{x} =~ /^[0-9.]+$/; |
58 | $win->{x} = ($_->{x} + $_->{w} * 0.5) / $::WIDTH if $_->{x} =~ /^[0-9.]+$/; |
59 | $win->{y} = ($_->{y} + $_->{h} * 0.5) / $::HEIGHT if $_->{y} =~ /^[0-9.]+$/; |
59 | $win->{y} = ($_->{y} + $_->{h} * 0.5) / $::HEIGHT if $_->{y} =~ /^[0-9.]+$/; |
60 | $win->{w} = $_->{w} / $::WIDTH if defined $_->{w}; |
60 | $win->{w} = $_->{w} / $::WIDTH if defined $_->{w}; |
61 | $win->{h} = $_->{h} / $::HEIGHT if defined $_->{h}; |
61 | $win->{h} = $_->{h} / $::HEIGHT if defined $_->{h}; |
62 | |
62 | |
… | |
… | |
71 | |
71 | |
72 | $LAYOUT = $layout; |
72 | $LAYOUT = $layout; |
73 | } |
73 | } |
74 | |
74 | |
75 | # class methods for events |
75 | # class methods for events |
76 | sub feed_sdl_key_down_event { |
76 | sub feed_sdl_key_down_event { |
77 | $FOCUS->emit (key_down => $_[0]) |
77 | $FOCUS->emit (key_down => $_[0]) |
78 | if $FOCUS; |
78 | if $FOCUS; |
79 | } |
79 | } |
80 | |
80 | |
81 | sub feed_sdl_key_up_event { |
81 | sub feed_sdl_key_up_event { |
… | |
… | |
223 | |
223 | |
224 | ############################################################################# |
224 | ############################################################################# |
225 | |
225 | |
226 | package DC::UI::Base; |
226 | package DC::UI::Base; |
227 | |
227 | |
228 | use strict; |
228 | use common::sense; |
229 | |
229 | |
230 | use DC::OpenGL; |
230 | use DC::OpenGL; |
231 | |
231 | |
232 | sub new { |
232 | sub new { |
233 | my $class = shift; |
233 | my $class = shift; |
… | |
… | |
363 | } |
363 | } |
364 | |
364 | |
365 | sub set_size { |
365 | sub set_size { |
366 | my ($self, $w, $h) = @_; |
366 | my ($self, $w, $h) = @_; |
367 | |
367 | |
368 | $self->{force_w} = $w; |
368 | $self->{force_w} = List::Util::min $w, ($self->{max_w} || $::WIDTH ); |
369 | $self->{force_h} = $h; |
369 | $self->{force_h} = List::Util::min $h, ($self->{max_h} || $::HEIGHT); |
370 | |
370 | |
371 | $self->realloc; |
371 | $self->realloc; |
372 | } |
372 | } |
373 | |
373 | |
374 | # traverse the widget chain up to find the maximum "physical" size constraints |
374 | ## traverse the widget chain up to find the maximum "physical" size constraints |
375 | sub get_max_wh { |
375 | #sub get_max_wh { |
376 | my ($self) = @_; |
376 | # my ($self) = @_; |
377 | |
377 | # |
378 | my ($w, $h) = @$self{qw(max_w max_h)}; |
378 | # my ($w, $h) = @$self{qw(max_w max_h)}; |
379 | |
379 | # |
380 | if ($w <= 0 || $h <= 0) { |
380 | # if ($w <= 0 || $h <= 0) { |
381 | my ($mw, $mh) = $self->{parent} |
381 | # my ($mw, $mh) = $self->{parent} |
382 | ? $self->{parent}->get_max_wh |
382 | # ? $self->{parent}->get_max_wh |
383 | : ($::WIDTH, $::HEIGHT); |
383 | # : ($::WIDTH, $::HEIGHT); |
384 | |
384 | # |
385 | $w = $mw if $w <= 0; |
385 | # $w = $mw if $w <= 0; |
386 | $h = $mh if $h <= 0; |
386 | # $h = $mh if $h <= 0; |
387 | } |
387 | # } |
388 | |
388 | # |
389 | ($w, $h) |
389 | # ($w, $h) |
390 | } |
390 | #} |
391 | |
391 | |
392 | sub size_request { |
392 | sub size_request { |
393 | require Carp; |
393 | require Carp; |
394 | Carp::confess "size_request is abstract"; |
394 | Carp::confess "size_request is abstract"; |
395 | } |
395 | } |
… | |
… | |
643 | |
643 | |
644 | package DC::UI::DrawBG; |
644 | package DC::UI::DrawBG; |
645 | |
645 | |
646 | our @ISA = DC::UI::Base::; |
646 | our @ISA = DC::UI::Base::; |
647 | |
647 | |
648 | use strict; |
648 | use common::sense; |
|
|
649 | |
649 | use DC::OpenGL; |
650 | use DC::OpenGL; |
650 | |
651 | |
651 | sub new { |
652 | sub new { |
652 | my $class = shift; |
653 | my $class = shift; |
653 | |
654 | |
… | |
… | |
666 | } |
667 | } |
667 | |
668 | |
668 | sub _draw { |
669 | sub _draw { |
669 | my ($self) = @_; |
670 | my ($self) = @_; |
670 | |
671 | |
671 | my $color = $FOCUS == $self && $self->{active_bg} |
672 | my $color = $FOCUS == $self |
672 | ? $self->{active_bg} |
673 | ? $self->{active_bg} || $self->{bg} |
673 | : $self->{bg}; |
674 | : $self->{bg}; |
674 | |
675 | |
675 | if ($color && (@$color < 4 || $color->[3])) { |
676 | if ($color && (@$color < 4 || $color->[3])) { |
676 | my ($w, $h) = @$self{qw(w h)}; |
677 | my ($w, $h) = @$self{qw(w h)}; |
677 | |
678 | |
… | |
… | |
1155 | |
1156 | |
1156 | $self->grab_focus; |
1157 | $self->grab_focus; |
1157 | |
1158 | |
1158 | my $ox = $self->{vp}{view_x}; |
1159 | my $ox = $self->{vp}{view_x}; |
1159 | my $oy = $self->{vp}{view_y}; |
1160 | my $oy = $self->{vp}{view_y}; |
1160 | |
1161 | |
1161 | $self->{motion} = sub { |
1162 | $self->{motion} = sub { |
1162 | my ($ev, $x, $y) = @_; |
1163 | my ($ev, $x, $y) = @_; |
1163 | |
1164 | |
1164 | $ox -= $ev->{xrel}; |
1165 | $ox -= $ev->{xrel}; |
1165 | $oy -= $ev->{yrel}; |
1166 | $oy -= $ev->{yrel}; |
… | |
… | |
1355 | |
1356 | |
1356 | our @ISA = DC::UI::Bin::; |
1357 | our @ISA = DC::UI::Bin::; |
1357 | |
1358 | |
1358 | use DC::OpenGL; |
1359 | use DC::OpenGL; |
1359 | |
1360 | |
1360 | my $bg = |
1361 | my $bg = |
1361 | new_from_resource DC::Texture "d1_bg.png", |
1362 | new_from_resource DC::Texture "d1_bg.png", |
1362 | mipmap => 1, wrap => 1; |
1363 | mipmap => 1, wrap => 1; |
1363 | |
1364 | |
1364 | my @border = |
1365 | my @border = |
1365 | map { new_from_resource DC::Texture $_, mipmap => 1 } |
1366 | map { new_from_resource DC::Texture $_, mipmap => 1 } |
1366 | qw(d1_border_top.png d1_border_right.png d1_border_left.png d1_border_bottom.png); |
1367 | qw(d1_border_top.png d1_border_right.png d1_border_left.png d1_border_bottom.png); |
1367 | |
1368 | |
1368 | my @icon = |
1369 | my @icon = |
1369 | map { new_from_resource DC::Texture $_, mipmap => 1 } |
1370 | map { new_from_resource DC::Texture $_, mipmap => 1 } |
… | |
… | |
1411 | |
1412 | |
1412 | sub border { |
1413 | sub border { |
1413 | int $_[0]{border} * $::FONTSIZE |
1414 | int $_[0]{border} * $::FONTSIZE |
1414 | } |
1415 | } |
1415 | |
1416 | |
1416 | sub get_max_wh { |
1417 | #sub get_max_wh { |
1417 | my ($self) = @_; |
1418 | # my ($self) = @_; |
1418 | |
1419 | # |
1419 | return ($self->{w}, $self->{h}) |
1420 | # return ($self->{w}, $self->{h}) |
1420 | if $self->{visible} && $self->{w}; |
1421 | # if $self->{visible} && $self->{w}; |
1421 | |
1422 | # |
1422 | $self->SUPER::get_max_wh |
1423 | # $self->SUPER::get_max_wh |
1423 | } |
1424 | #} |
1424 | |
1425 | |
1425 | sub size_request { |
1426 | sub size_request { |
1426 | my ($self) = @_; |
1427 | my ($self) = @_; |
1427 | |
1428 | |
1428 | $self->{title_widget}->size_request |
1429 | $self->{title_widget}->size_request |
… | |
… | |
1463 | |
1464 | |
1464 | sub invoke_delete { |
1465 | sub invoke_delete { |
1465 | my ($self) = @_; |
1466 | my ($self) = @_; |
1466 | |
1467 | |
1467 | $self->hide; |
1468 | $self->hide; |
1468 | |
1469 | |
1469 | 1 |
1470 | 1 |
1470 | } |
1471 | } |
1471 | |
1472 | |
1472 | sub invoke_button_down { |
1473 | sub invoke_button_down { |
1473 | my ($self, $ev, $x, $y) = @_; |
1474 | my ($self, $ev, $x, $y) = @_; |
1474 | |
1475 | |
1475 | my ($w, $h) = @$self{qw(w h)}; |
1476 | my ($w, $h) = @$self{qw(w h)}; |
1476 | my $border = $self->border; |
1477 | my $border = $self->border; |
1477 | |
1478 | |
1478 | my $lr = ($x >= 0 && $x < $border) || ($x > $w - $border && $x < $w); |
1479 | my $lr = ($x >= 0 && $x < $border) || ($x > $w - $border && $x < $w); # left-right |
1479 | my $td = ($y >= 0 && $y < $border) || ($y > $h - $border && $y < $h); |
1480 | my $td = ($y >= 0 && $y < $border) || ($y > $h - $border && $y < $h); # top-down |
1480 | |
1481 | |
1481 | if ($lr & $td) { |
1482 | if ($lr & $td) { # corners |
1482 | my ($wx, $wy) = ($self->{x}, $self->{y}); |
1483 | my ($wx, $wy) = ($self->{x}, $self->{y}); |
1483 | my ($ox, $oy) = ($ev->{x}, $ev->{y}); |
1484 | my ($ox, $oy) = ($ev->{x}, $ev->{y}); |
1484 | my ($bw, $bh) = ($self->{w}, $self->{h}); |
1485 | my ($bw, $bh) = ($self->{w}, $self->{h}); |
1485 | |
1486 | |
1486 | my $mx = $x < $border; |
1487 | my $mx = $x < $border; |
… | |
… | |
1490 | my ($ev, $x, $y) = @_; |
1491 | my ($ev, $x, $y) = @_; |
1491 | |
1492 | |
1492 | my $dx = $ev->{x} - $ox; |
1493 | my $dx = $ev->{x} - $ox; |
1493 | my $dy = $ev->{y} - $oy; |
1494 | my $dy = $ev->{y} - $oy; |
1494 | |
1495 | |
|
|
1496 | $self->set_size ( |
1495 | $self->{force_w} = $bw + $dx * ($mx ? -1 : 1); |
1497 | $bw + $dx * ($mx ? -1 : 1), |
1496 | $self->{force_h} = $bh + $dy * ($my ? -1 : 1); |
1498 | $bh + $dy * ($my ? -1 : 1), |
|
|
1499 | ); |
1497 | |
1500 | |
1498 | $self->move_abs ($wx + $dx * $mx, $wy + $dy * $my); |
1501 | $self->move_abs ($wx + $dx * $mx, $wy + $dy * $my); |
1499 | $self->realloc; |
1502 | $self->realloc; |
1500 | }; |
1503 | }; |
1501 | |
1504 | |
1502 | } elsif ($lr ^ $td) { |
1505 | } elsif ($lr ^ $td) { # edges |
1503 | my ($ox, $oy) = ($ev->{x}, $ev->{y}); |
1506 | my ($ox, $oy) = ($ev->{x}, $ev->{y}); |
1504 | my ($bx, $by) = ($self->{x}, $self->{y}); |
1507 | my ($bx, $by) = ($self->{x}, $self->{y}); |
1505 | |
1508 | |
1506 | $self->{motion} = sub { |
1509 | $self->{motion} = sub { |
1507 | my ($ev, $x, $y) = @_; |
1510 | my ($ev, $x, $y) = @_; |
… | |
… | |
1837 | if ($req > $space) { |
1840 | if ($req > $space) { |
1838 | # ah well, not enough space |
1841 | # ah well, not enough space |
1839 | $_ *= $space / $req for @req; |
1842 | $_ *= $space / $req for @req; |
1840 | } else { |
1843 | } else { |
1841 | my $expand = (List::Util::sum map $_->{expand}, @children) || 1; |
1844 | my $expand = (List::Util::sum map $_->{expand}, @children) || 1; |
1842 | |
1845 | |
1843 | $space = ($space - $req) / $expand; # remaining space to give away |
1846 | $space = ($space - $req) / $expand; # remaining space to give away |
1844 | |
1847 | |
1845 | $req[$_] += $space * $children[$_]{expand} |
1848 | $req[$_] += $space * $children[$_]{expand} |
1846 | for 0 .. $#children; |
1849 | for 0 .. $#children; |
1847 | } |
1850 | } |
… | |
… | |
1986 | |
1989 | |
1987 | sub size_request { |
1990 | sub size_request { |
1988 | my ($self) = @_; |
1991 | my ($self) = @_; |
1989 | |
1992 | |
1990 | $self->{size_req} ||= do { |
1993 | $self->{size_req} ||= do { |
1991 | my ($max_w, $max_h) = $self->get_max_wh; |
1994 | my $max_w = $self->{w} || $self->{max_w} || 0x0fffffff; # actually 2**31-1 but allow for overflow inside pango |
1992 | |
1995 | |
1993 | $self->{layout}->set_font ($self->{font}) if $self->{font}; |
1996 | $self->{layout}->set_font ($self->{font}) if $self->{font}; |
1994 | $self->{layout}->set_width ($max_w); |
1997 | $self->{layout}->set_width ($max_w); |
1995 | $self->{layout}->set_ellipsise ($self->{ellipsise}); |
1998 | $self->{layout}->set_ellipsise ($self->{ellipsise}); |
1996 | $self->{layout}->set_single_paragraph_mode ($self->{ellipsise}); |
1999 | $self->{layout}->set_single_paragraph_mode ($self->{ellipsise}); |
… | |
… | |
2076 | # $self->{list} = DC::OpenGL::glGenList; |
2079 | # $self->{list} = DC::OpenGL::glGenList; |
2077 | # DC::OpenGL::glNewList $self->{list}; |
2080 | # DC::OpenGL::glNewList $self->{list}; |
2078 | # $self->{layout}->render ($self->{ox}, $self->{oy}, $self->{style}); |
2081 | # $self->{layout}->render ($self->{ox}, $self->{oy}, $self->{style}); |
2079 | # DC::OpenGL::glEndList; |
2082 | # DC::OpenGL::glEndList; |
2080 | # } |
2083 | # } |
2081 | # |
2084 | # |
2082 | # DC::OpenGL::glCallList $self->{list}; |
2085 | # DC::OpenGL::glCallList $self->{list}; |
2083 | |
2086 | |
2084 | $self->{layout}->draw; |
2087 | $self->{layout}->draw; |
2085 | } |
2088 | } |
2086 | |
2089 | |
… | |
… | |
2235 | utf8::encode $text; $text = substr $text, 0, $idx; utf8::decode $text; |
2238 | utf8::encode $text; $text = substr $text, 0, $idx; utf8::decode $text; |
2236 | $self->{cursor} = length $text; |
2239 | $self->{cursor} = length $text; |
2237 | |
2240 | |
2238 | $self->_set_text ($self->{text}); |
2241 | $self->_set_text ($self->{text}); |
2239 | $self->update; |
2242 | $self->update; |
2240 | |
2243 | |
2241 | 1 |
2244 | 1 |
2242 | } |
2245 | } |
2243 | |
2246 | |
2244 | sub invoke_mouse_motion { |
2247 | sub invoke_mouse_motion { |
2245 | my ($self, $ev, $x, $y) = @_; |
2248 | my ($self, $ev, $x, $y) = @_; |
… | |
… | |
2594 | |
2597 | |
2595 | ############################################################################# |
2598 | ############################################################################# |
2596 | |
2599 | |
2597 | package DC::UI::Image; |
2600 | package DC::UI::Image; |
2598 | |
2601 | |
2599 | our @ISA = DC::UI::Base::; |
2602 | our @ISA = DC::UI::DrawBG::; |
2600 | |
2603 | |
2601 | use DC::OpenGL; |
2604 | use DC::OpenGL; |
2602 | |
2605 | |
2603 | our %texture_cache; |
2606 | our %texture_cache; |
2604 | |
2607 | |
… | |
… | |
2637 | my ($self, $cloning, $path) = @_; |
2640 | my ($self, $cloning, $path) = @_; |
2638 | |
2641 | |
2639 | $self->new (path => $path) |
2642 | $self->new (path => $path) |
2640 | } |
2643 | } |
2641 | |
2644 | |
|
|
2645 | sub set_texture { |
|
|
2646 | my ($self, $tex) = @_; |
|
|
2647 | |
|
|
2648 | $self->{tex} = $tex; |
|
|
2649 | $self->update; |
|
|
2650 | } |
|
|
2651 | |
2642 | sub size_request { |
2652 | sub size_request { |
2643 | my ($self) = @_; |
2653 | my ($self) = @_; |
2644 | |
2654 | |
2645 | (int $self->{tex}{w} * $self->{scale}, int $self->{tex}{h} * $self->{scale}) |
2655 | (int $self->{tex}{w} * $self->{scale}, int $self->{tex}{h} * $self->{scale}) |
2646 | } |
2656 | } |
2647 | |
2657 | |
2648 | sub _draw { |
2658 | sub _draw { |
2649 | my ($self) = @_; |
2659 | my ($self) = @_; |
|
|
2660 | |
|
|
2661 | $self->SUPER::_draw; |
2650 | |
2662 | |
2651 | my $tex = $self->{tex}; |
2663 | my $tex = $self->{tex}; |
2652 | |
2664 | |
2653 | my ($w, $h) = ($self->{w}, $self->{h}); |
2665 | my ($w, $h) = ($self->{w}, $self->{h}); |
2654 | |
2666 | |
… | |
… | |
2672 | package DC::UI::ImageButton; |
2684 | package DC::UI::ImageButton; |
2673 | |
2685 | |
2674 | our @ISA = DC::UI::Image::; |
2686 | our @ISA = DC::UI::Image::; |
2675 | |
2687 | |
2676 | use DC::OpenGL; |
2688 | use DC::OpenGL; |
2677 | |
|
|
2678 | my %textures; |
|
|
2679 | |
2689 | |
2680 | sub new { |
2690 | sub new { |
2681 | my $class = shift; |
2691 | my $class = shift; |
2682 | |
2692 | |
2683 | my $self = $class->SUPER::new ( |
2693 | my $self = $class->SUPER::new ( |
… | |
… | |
3047 | |
3057 | |
3048 | ############################################################################# |
3058 | ############################################################################# |
3049 | |
3059 | |
3050 | package DC::UI::Slider; |
3060 | package DC::UI::Slider; |
3051 | |
3061 | |
3052 | use strict; |
3062 | use common::sense; |
3053 | |
3063 | |
3054 | use DC::OpenGL; |
3064 | use DC::OpenGL; |
3055 | |
3065 | |
3056 | our @ISA = DC::UI::DrawBG::; |
3066 | our @ISA = DC::UI::DrawBG::; |
3057 | |
3067 | |
… | |
… | |
3129 | my ($self, $ev, $x, $y) = @_; |
3139 | my ($self, $ev, $x, $y) = @_; |
3130 | |
3140 | |
3131 | $self->SUPER::invoke_button_down ($ev, $x, $y); |
3141 | $self->SUPER::invoke_button_down ($ev, $x, $y); |
3132 | |
3142 | |
3133 | $self->{click} = [$self->{range}[0], $self->{vertical} ? $y : $x]; |
3143 | $self->{click} = [$self->{range}[0], $self->{vertical} ? $y : $x]; |
3134 | |
3144 | |
3135 | $self->invoke_mouse_motion ($ev, $x, $y); |
3145 | $self->invoke_mouse_motion ($ev, $x, $y); |
3136 | |
3146 | |
3137 | 1 |
3147 | 1 |
3138 | } |
3148 | } |
3139 | |
3149 | |
… | |
… | |
3143 | if ($GRAB == $self) { |
3153 | if ($GRAB == $self) { |
3144 | my ($x, $w) = $self->{vertical} ? ($y, $self->{h}) : ($x, $self->{w}); |
3154 | my ($x, $w) = $self->{vertical} ? ($y, $self->{h}) : ($x, $self->{w}); |
3145 | |
3155 | |
3146 | my (undef, $lo, $hi, $page) = @{$self->{range}}; |
3156 | my (undef, $lo, $hi, $page) = @{$self->{range}}; |
3147 | |
3157 | |
3148 | $x = ($x - $self->{click}[1]) / ($w * $self->{scale}); |
3158 | $x = ($x - $self->{click}[1]) / ($w * $self->{scale} || 1e999); |
3149 | |
3159 | |
3150 | $self->set_value ($self->{click}[0] + $x * ($hi - $page - $lo)); |
3160 | $self->set_value ($self->{click}[0] + $x * ($hi - $page - $lo)); |
3151 | } else { |
3161 | } else { |
3152 | return 0; |
3162 | return 0; |
3153 | } |
3163 | } |
… | |
… | |
3199 | |
3209 | |
3200 | glScale $self->{w}, $self->{h}; |
3210 | glScale $self->{w}, $self->{h}; |
3201 | |
3211 | |
3202 | if ($self->{vertical}) { |
3212 | if ($self->{vertical}) { |
3203 | # draw a vertical slider like a rotated horizontal slider |
3213 | # draw a vertical slider like a rotated horizontal slider |
3204 | |
3214 | |
3205 | glTranslate 1, 0, 0; |
3215 | glTranslate 1, 0, 0; |
3206 | glRotate 90, 0, 0, 1; |
3216 | glRotate 90, 0, 0, 1; |
3207 | } |
3217 | } |
3208 | |
3218 | |
3209 | my $fg = $FOCUS == $self ? $self->{active_fg} : $self->{fg}; |
3219 | my $fg = $FOCUS == $self ? $self->{active_fg} : $self->{fg}; |
… | |
… | |
3277 | fontsize => 1, |
3287 | fontsize => 1, |
3278 | can_events => 1, |
3288 | can_events => 1, |
3279 | indent => 0, |
3289 | indent => 0, |
3280 | #font => default_font |
3290 | #font => default_font |
3281 | @_, |
3291 | @_, |
3282 | |
3292 | |
3283 | layout => (new DC::Layout), |
3293 | layout => (new DC::Layout), |
3284 | par => [], |
|
|
3285 | max_par => 0, |
3294 | max_par => 0, |
3286 | height => 0, |
3295 | height => 0, |
3287 | children => [ |
3296 | children => [ |
3288 | (new DC::UI::Empty expand => 1), |
3297 | (new DC::UI::Empty expand => 1), |
3289 | (new DC::UI::Slider vertical => 1), |
3298 | (new DC::UI::Slider vertical => 1), |
3290 | ], |
3299 | ], |
3291 | ); |
3300 | ); |
3292 | |
3301 | |
3293 | $self->{children}[1]->connect (changed => sub { $self->update }); |
3302 | $self->{children}[1]->connect (changed => sub { $self->update }); |
|
|
3303 | |
|
|
3304 | $self->add_paragraph (@{ delete $self->{par} }) if @{ $self->{par} }; |
3294 | |
3305 | |
3295 | $self |
3306 | $self |
3296 | } |
3307 | } |
3297 | |
3308 | |
3298 | sub set_fontsize { |
3309 | sub set_fontsize { |
… | |
… | |
3562 | my ($self, $x, $y) = @_; |
3573 | my ($self, $x, $y) = @_; |
3563 | |
3574 | |
3564 | $self->{moveto} = [$self->{x}, $self->{y}, $x, $y]; |
3575 | $self->{moveto} = [$self->{x}, $self->{y}, $x, $y]; |
3565 | $self->{speed} = 0.001; |
3576 | $self->{speed} = 0.001; |
3566 | $self->{time} = 1; |
3577 | $self->{time} = 1; |
3567 | |
3578 | |
3568 | ::animation_start $self; |
3579 | ::animation_start $self; |
3569 | } |
3580 | } |
3570 | |
3581 | |
3571 | sub animate { |
3582 | sub animate { |
3572 | my ($self, $interval) = @_; |
3583 | my ($self, $interval) = @_; |
… | |
… | |
3576 | $self->{time} = 0; |
3587 | $self->{time} = 0; |
3577 | ::animation_stop $self; |
3588 | ::animation_stop $self; |
3578 | } |
3589 | } |
3579 | |
3590 | |
3580 | my ($x0, $y0, $x1, $y1) = @{$self->{moveto}}; |
3591 | my ($x0, $y0, $x1, $y1) = @{$self->{moveto}}; |
3581 | |
3592 | |
3582 | $self->{x} = $x0 * $self->{time} + $x1 * (1 - $self->{time}); |
3593 | $self->{x} = $x0 * $self->{time} + $x1 * (1 - $self->{time}); |
3583 | $self->{y} = $y0 * $self->{time} + $y1 * (1 - $self->{time}); |
3594 | $self->{y} = $y0 * $self->{time} + $y1 * (1 - $self->{time}); |
3584 | } |
3595 | } |
3585 | |
3596 | |
3586 | sub _draw { |
3597 | sub _draw { |
… | |
… | |
3631 | @_, |
3642 | @_, |
3632 | can_events => 0, |
3643 | can_events => 0, |
3633 | ) |
3644 | ) |
3634 | } |
3645 | } |
3635 | |
3646 | |
|
|
3647 | # expand, as good as possible |
|
|
3648 | sub _expand_doclets { |
|
|
3649 | my ($tip) = @_; |
|
|
3650 | |
|
|
3651 | $tip =~ s{#\(([^)]+)\)}{ |
|
|
3652 | if ($::CONN) { |
|
|
3653 | exists $::CONN->{doclet}{$1} |
|
|
3654 | ? $::CONN->{doclet}{$1} |
|
|
3655 | : "(waiting for server to show full text)" |
|
|
3656 | } else { |
|
|
3657 | "(unable to show full text without server connection)" |
|
|
3658 | } |
|
|
3659 | }ge; |
|
|
3660 | |
|
|
3661 | $tip =~ s/^\n+//; |
|
|
3662 | $tip =~ s/\n+$//; |
|
|
3663 | |
|
|
3664 | $tip |
|
|
3665 | } |
|
|
3666 | |
|
|
3667 | # expands a tooltip, potentially multiple times remotely |
|
|
3668 | # and returns a guard. clals the clalback each time the text changes. |
|
|
3669 | sub expand_tooltip { |
|
|
3670 | my ($tip, $cb) = @_; |
|
|
3671 | |
|
|
3672 | # first expand #name tooltips from local pod |
|
|
3673 | $tip = DC::Pod::section_label tooltip => $1 |
|
|
3674 | if $tip =~ /^#([^(].*)$/; |
|
|
3675 | |
|
|
3676 | my $active; # true if any remote requests outstanding |
|
|
3677 | |
|
|
3678 | if ($::CONN && $::CONN->{addme_success}) { |
|
|
3679 | # now find all doclet references |
|
|
3680 | for my $doclet ($tip =~ /#\(([^)]+)\)/g) { |
|
|
3681 | unless (exists $::CONN->{doclet}{$doclet}) { |
|
|
3682 | # need to ask the server |
|
|
3683 | # we don't try to avoid duplicate requests |
|
|
3684 | |
|
|
3685 | $active = 1; |
|
|
3686 | $::CONN->send_exti_req (doclet => (split /\//, $doclet, 2), sub { |
|
|
3687 | $::CONN->{doclet}{$doclet} = DC::sanitise_cfxml $_[0]; |
|
|
3688 | $cb->(_expand_doclets $tip) if $active; |
|
|
3689 | }); |
|
|
3690 | } |
|
|
3691 | } |
|
|
3692 | } |
|
|
3693 | |
|
|
3694 | $cb->(_expand_doclets $tip); |
|
|
3695 | |
|
|
3696 | $active and Guard::guard { undef $active } |
|
|
3697 | } |
|
|
3698 | |
3636 | sub set_tooltip_from { |
3699 | sub set_tooltip_from { |
3637 | my ($self, $widget) = @_; |
3700 | my ($self, $widget) = @_; |
3638 | |
3701 | |
3639 | my $tip = $widget->{tooltip}; |
3702 | my $tip = $widget->{tooltip}; |
3640 | $tip = $tip->($widget) if "CODE" eq ref $tip; |
3703 | $tip = $tip->($widget) if "CODE" eq ref $tip; |
3641 | |
|
|
3642 | $tip = DC::Pod::section_label tooltip => $1 |
|
|
3643 | if $tip =~ /^#(.*)$/; |
|
|
3644 | |
|
|
3645 | if ($ENV{CFPLUS_DEBUG} & 2) { |
|
|
3646 | $tip .= "\n\n" . (ref $widget) . "\n" |
|
|
3647 | . "$widget->{x} $widget->{y} $widget->{w} $widget->{h}\n" |
|
|
3648 | . "req $widget->{req_w} $widget->{req_h}\n" |
|
|
3649 | . "visible $widget->{visible}"; |
|
|
3650 | } |
|
|
3651 | |
|
|
3652 | $tip =~ s/^\n+//; |
|
|
3653 | $tip =~ s/\n+$//; |
|
|
3654 | |
3704 | |
3655 | $self->add (new DC::UI::Label |
3705 | $self->add (new DC::UI::Label |
3656 | fg => $DC::THEME{tooltip_fg}, |
3706 | fg => $DC::THEME{tooltip_fg}, |
3657 | markup => $tip, |
|
|
3658 | max_w => ($widget->{tooltip_width} || 0.25) * $::WIDTH, |
3707 | max_w => ($widget->{tooltip_width} || 0.25) * $::WIDTH, |
3659 | align => 0, |
3708 | align => 0, |
3660 | fontsize => 0.8, |
3709 | fontsize => 0.8, |
3661 | style => $DC::THEME{tooltip_style}, # FLAG_INVERSE |
3710 | style => $DC::THEME{tooltip_style}, # FLAG_INVERSE |
3662 | ellipsise => 0, |
3711 | ellipsise => 0, |
3663 | font => ($widget->{tooltip_font} || $::FONT_PROP), |
3712 | font => ($widget->{tooltip_font} || $::FONT_PROP), |
3664 | ); |
3713 | ); |
|
|
3714 | |
|
|
3715 | $self->{tooltip_expand} = expand_tooltip $tip, sub { |
|
|
3716 | my ($tip) = @_; |
|
|
3717 | |
|
|
3718 | if ($ENV{CFPLUS_DEBUG} & 2) { |
|
|
3719 | $tip .= "\n\n" . (ref $widget) . "\n" |
|
|
3720 | . "$widget->{x} $widget->{y} $widget->{w} $widget->{h}\n" |
|
|
3721 | . "req $widget->{req_w} $widget->{req_h}\n" |
|
|
3722 | . "visible $widget->{visible}"; |
|
|
3723 | } |
|
|
3724 | |
|
|
3725 | $self->{children}[0]->set_markup ($tip); |
|
|
3726 | }; |
3665 | } |
3727 | } |
3666 | |
3728 | |
3667 | sub size_request { |
3729 | sub size_request { |
3668 | my ($self) = @_; |
3730 | my ($self) = @_; |
3669 | |
3731 | |
… | |
… | |
3705 | |
3767 | |
3706 | my ($w, $h) = @$self{qw(w h)}; |
3768 | my ($w, $h) = @$self{qw(w h)}; |
3707 | |
3769 | |
3708 | glColor @{ $DC::THEME{tooltip_bg} }; |
3770 | glColor @{ $DC::THEME{tooltip_bg} }; |
3709 | glRect 0, 0, $w, $h; |
3771 | glRect 0, 0, $w, $h; |
3710 | |
3772 | |
3711 | glColor @{ $DC::THEME{tooltip_border} }; |
3773 | glColor @{ $DC::THEME{tooltip_border} }; |
3712 | glRect_lineloop .5, .5, $w + .5, $h + .5; |
3774 | glRect_lineloop .5, .5, $w + .5, $h + .5; |
3713 | |
3775 | |
3714 | glTranslate 2, 2; |
3776 | glTranslate 2, 2; |
3715 | |
3777 | |
3716 | $self->SUPER::_draw; |
3778 | $self->SUPER::_draw; |
3717 | } |
3779 | } |
3718 | |
3780 | |
… | |
… | |
3734 | can_events => 0, |
3796 | can_events => 0, |
3735 | @_, |
3797 | @_, |
3736 | ); |
3798 | ); |
3737 | |
3799 | |
3738 | $self->update_anim; |
3800 | $self->update_anim; |
3739 | |
3801 | |
3740 | $self |
3802 | $self |
3741 | } |
3803 | } |
3742 | |
3804 | |
3743 | sub update_timer { |
3805 | sub update_timer { |
3744 | my ($self) = @_; |
3806 | my ($self) = @_; |
… | |
… | |
4285 | $self |
4347 | $self |
4286 | } |
4348 | } |
4287 | |
4349 | |
4288 | sub reorder { |
4350 | sub reorder { |
4289 | my ($self) = @_; |
4351 | my ($self) = @_; |
4290 | my $NOW = EV::time; |
4352 | my $NOW = AE::time; |
4291 | |
4353 | |
4292 | # freeze display when hovering over any label |
4354 | # freeze display when hovering over any label |
4293 | return if $DC::UI::TOOLTIP->{owner} |
4355 | return if $DC::UI::TOOLTIP->{owner} |
4294 | && grep $DC::UI::TOOLTIP->{owner} == $_->{label}, |
4356 | && grep $DC::UI::TOOLTIP->{owner} == $_->{label}, |
4295 | values %{ $self->{item} }; |
4357 | values %{ $self->{item} }; |
… | |
… | |
4394 | $ROOT->on_refresh (reorder => sub { |
4456 | $ROOT->on_refresh (reorder => sub { |
4395 | $self->reorder; |
4457 | $self->reorder; |
4396 | }); |
4458 | }); |
4397 | } |
4459 | } |
4398 | |
4460 | |
|
|
4461 | sub clr_group { |
|
|
4462 | my ($self, $group) = @_; |
|
|
4463 | |
|
|
4464 | if (delete $self->{item}{$group}) { |
|
|
4465 | $ROOT->on_refresh (reorder => sub { |
|
|
4466 | $self->reorder; |
|
|
4467 | }); |
|
|
4468 | } |
|
|
4469 | } |
|
|
4470 | |
4399 | sub reconfigure { |
4471 | sub reconfigure { |
4400 | my ($self) = @_; |
4472 | my ($self) = @_; |
4401 | |
4473 | |
4402 | delete $_->{label} |
4474 | delete $_->{label} |
4403 | for values %{ $self->{item} || {} }; |
4475 | for values %{ $self->{item} || {} }; |
… | |
… | |
4557 | while () { |
4629 | while () { |
4558 | @queue or last outer; |
4630 | @queue or last outer; |
4559 | |
4631 | |
4560 | $widget = pop @{ $queue[-1] || [] } |
4632 | $widget = pop @{ $queue[-1] || [] } |
4561 | and last; |
4633 | and last; |
4562 | |
4634 | |
4563 | pop @queue; |
4635 | pop @queue; |
4564 | } |
4636 | } |
4565 | |
4637 | |
4566 | delete $queue{$widget+0}; |
4638 | delete $queue{$widget+0}; |
4567 | |
4639 | |