… | |
… | |
3 | package chat; |
3 | package chat; |
4 | |
4 | |
5 | # waaay cool widget. well... maybe at one point in the future |
5 | # waaay cool widget. well... maybe at one point in the future |
6 | |
6 | |
7 | use Gtk2; |
7 | use Gtk2; |
|
|
8 | use Gtk2::Pango; |
8 | |
9 | |
9 | use Glib::Object::Subclass |
10 | use Glib::Object::Subclass |
10 | Gtk2::VBox, |
11 | Gtk2::VBox, |
11 | signals => { |
12 | signals => { |
12 | command => { |
13 | command => { |
13 | flags => [qw/run-first/], |
14 | flags => [qw/run-last/], |
14 | return_type => undef, # void return |
15 | return_type => undef, |
15 | param_types => [Glib::Scalar, Glib::Scalar], |
16 | param_types => [Glib::Scalar, Glib::Scalar], |
|
|
17 | class_closure => sub { }, |
|
|
18 | }, |
|
|
19 | tag_event => { |
|
|
20 | flags => [qw/run-last/], |
|
|
21 | return_type => undef, |
|
|
22 | # tag, event, content |
|
|
23 | param_types => [Glib::String, Gtk2::Gdk::Event, Glib::String], |
|
|
24 | class_closure => \&tag_event, |
|
|
25 | }, |
|
|
26 | enter_tag => { |
|
|
27 | flags => [qw/run-last/], |
|
|
28 | return_type => undef, |
|
|
29 | # tag, content |
|
|
30 | param_types => [Glib::String, Glib::String], |
|
|
31 | class_closure => sub { }, |
|
|
32 | }, |
|
|
33 | leave_tag => { |
|
|
34 | flags => [qw/run-last/], |
|
|
35 | return_type => undef, |
|
|
36 | # tag, content |
|
|
37 | param_types => [Glib::String, Glib::String], |
|
|
38 | class_closure => sub { }, |
16 | }, |
39 | }, |
17 | }; |
40 | }; |
18 | |
41 | |
|
|
42 | sub new { |
|
|
43 | my ($self, %arg) = @_; |
|
|
44 | |
|
|
45 | $self = $self->Glib::Object::new; |
|
|
46 | $self->{$_} = delete $arg{$_} for keys %arg; |
|
|
47 | |
|
|
48 | $self; |
|
|
49 | } |
|
|
50 | |
19 | sub INIT_INSTANCE { |
51 | sub INIT_INSTANCE { |
20 | my $self = shift; |
52 | my $self = shift; |
21 | |
53 | |
22 | my $tagtable = new Gtk2::TextTagTable; |
54 | my $tagtable = new Gtk2::TextTagTable; |
23 | |
55 | |
24 | { |
56 | { |
25 | my @tags = ( |
57 | my @tags = ( |
26 | [default => { foreground => "black" }], |
58 | [default => { foreground => "black", wrap_mode => "word-char" }], |
27 | [node => { foreground => "#0000b0", event => 1 }], |
59 | [node => { foreground => "#0000b0", event => 1 }], |
28 | [move => { foreground => "#0000b0", event => 1 }], |
60 | [move => { foreground => "#0000b0", event => 1 }], |
29 | [user => { foreground => "#0000b0", wrap_mode => "none", event => 1 }], |
61 | [user => { foreground => "#0000b0", event => 1 }], |
30 | [coord => { foreground => "#0000b0", event => 1 }], |
62 | [coord => { foreground => "#0000b0", event => 1 }], |
31 | [score => { foreground => "#0000b0", event => 1 }], |
63 | [score => { foreground => "#0000b0", event => 1 }], |
32 | [error => { foreground => "#ff0000", event => 1 }], |
64 | [error => { foreground => "#ff0000", event => 1 }], |
33 | [leader => { weight => 800, pixels_above_lines => 6 }], |
65 | [leader => { weight => 800, pixels_above_lines => 6 }], |
34 | [header => { weight => 800, pixels_above_lines => 6 }], |
66 | [header => { weight => 800, pixels_above_lines => 6 }], |
… | |
… | |
40 | |
72 | |
41 | for (@tags) { |
73 | for (@tags) { |
42 | my ($k, $v) = @$_; |
74 | my ($k, $v) = @$_; |
43 | my $tag = new Gtk2::TextTag $k; |
75 | my $tag = new Gtk2::TextTag $k; |
44 | if (delete $v->{event}) { |
76 | if (delete $v->{event}) { |
|
|
77 | $tag->signal_connect (event => sub { |
|
|
78 | my ($tag, $view, $event, $iter) = @_; |
|
|
79 | |
|
|
80 | return 0 if $event->type eq "motion-notify"; |
45 | ### |
81 | |
|
|
82 | my ($a, $b) = ($iter, $iter->copy); |
|
|
83 | $a->backward_to_tag_toggle ($tag) unless $a->begins_tag ($tag); |
|
|
84 | $b->forward_to_tag_toggle ($tag) unless $b->ends_tag ($tag); |
|
|
85 | |
|
|
86 | $self->signal_emit (tag_event => $k, $event, $a->get_text ($b)); |
|
|
87 | |
|
|
88 | 1; |
|
|
89 | }); |
46 | } |
90 | } |
47 | $tag->set (%$v); |
91 | $tag->set (%$v); |
48 | $tagtable->add ($tag); |
92 | $tagtable->add ($tag); |
49 | } |
93 | } |
50 | } |
94 | } |
… | |
… | |
57 | }); |
101 | }); |
58 | |
102 | |
59 | $self->{buffer} = new Gtk2::TextBuffer $self->{tagtable}; |
103 | $self->{buffer} = new Gtk2::TextBuffer $self->{tagtable}; |
60 | |
104 | |
61 | $self->{widget} = new Gtk2::ScrolledWindow; |
105 | $self->{widget} = new Gtk2::ScrolledWindow; |
62 | $self->{widget}->set_policy("never", "always"); |
106 | $self->{widget}->set_policy ("automatic", "always"); |
63 | $self->pack_start ($self->{widget}, 1, 1, 0); |
107 | $self->pack_start ($self->{widget}, 1, 1, 0); |
64 | |
108 | |
65 | $self->{widget}->add ($self->{view} = new_with_buffer Gtk2::TextView $self->{buffer}); |
109 | $self->{widget}->add ($self->{view} = new_with_buffer Gtk2::TextView $self->{buffer}); |
66 | $self->{view}->set_wrap_mode ("word-char"); |
|
|
67 | $self->{view}->set_cursor_visible (0); |
|
|
68 | |
|
|
69 | $self->{view}->set_editable (0); |
110 | $self->{view}->set ( |
|
|
111 | wrap_mode => "word-char", |
|
|
112 | cursor_visible => 0, |
|
|
113 | editable => 0, |
|
|
114 | tabs => |
|
|
115 | (new Gtk2::Pango::TabArray 1, 0, left => 125000), # arbitrary... pango is underfeatured |
|
|
116 | ); |
70 | |
117 | |
71 | $self->{view}->signal_connect (motion_notify_event => sub { |
118 | $self->{view}->signal_connect (motion_notify_event => sub { |
72 | my ($widget, $event) = @_; |
119 | my ($widget, $event) = @_; |
73 | |
120 | |
74 | my $window = $widget->get_window ("text"); |
121 | my $window = $widget->get_window ("text"); |
75 | if ($event->window == $window) { |
122 | if ($event->window == $window) { |
76 | my ($win, $x, $y, $mask) = $window->get_pointer; |
123 | my ($win, $x, $y, $mask) = $window->get_pointer; |
77 | # warn "TAG EVENT @_ ($window, $win, $x, $y, $mask)\n"; |
124 | ($x, $y) = $self->{view}->window_to_buffer_coords ("text", $x, $y); |
78 | #gtk_text_view_window_to_buffer_coords (text_view, |
125 | my ($iter) = $self->{view}->get_iter_at_location ($x, $y); |
79 | # GTK_TEXT_WINDOW_TEXT, |
126 | |
80 | # text_view->drag_start_x, |
127 | my $tag = ($iter->get_tags)[01]; |
81 | # text_view->drag_start_y, |
128 | |
82 | # &buffer_x, |
129 | if ($tag) { |
83 | # &buffer_y); |
130 | my ($a, $b) = ($iter, $iter->copy); |
84 | # |
131 | $a->backward_to_tag_toggle ($tag) unless $a->begins_tag ($tag); |
85 | # gtk_text_layout_get_iter_at_pixel (text_view->layout, |
132 | $b->forward_to_tag_toggle ($tag) unless $b->ends_tag ($tag); |
86 | # &iter, |
133 | |
87 | # buffer_x, buffer_y); |
134 | $self->tag_enterleave ($tag->get ("name"), $a->get_text ($b)); |
88 | # |
135 | } else { |
89 | # gtk_text_view_start_selection_dnd (text_view, &iter, event); |
136 | $self->tag_enterleave (); |
90 | # return TRUE; |
137 | } |
|
|
138 | |
|
|
139 | 1; |
91 | } |
140 | } |
92 | 0; |
141 | 0; |
93 | }); |
142 | }); |
|
|
143 | |
|
|
144 | $self->{view}->signal_connect (leave_notify_event => sub { |
|
|
145 | $self->tag_enterleave (); |
|
|
146 | 0; |
|
|
147 | }); |
|
|
148 | |
|
|
149 | $self->{view}->add_events (qw(leave_notify_mask)); |
94 | |
150 | |
95 | $self->pack_start (($self->{entry} = new Gtk2::Entry), 0, 1, 0); |
151 | $self->pack_start (($self->{entry} = new Gtk2::Entry), 0, 1, 0); |
96 | |
152 | |
97 | $self->{entry}->signal_connect (activate => sub { |
153 | $self->{entry}->signal_connect (activate => sub { |
98 | my ($entry) = @_; |
154 | my ($entry) = @_; |
… | |
… | |
114 | $self->{end} = $self->{buffer}->create_mark (++$USELESSNAME, $self->{buffer}->get_end_iter, 0); # workaround for gtk-perl bug |
170 | $self->{end} = $self->{buffer}->create_mark (++$USELESSNAME, $self->{buffer}->get_end_iter, 0); # workaround for gtk-perl bug |
115 | |
171 | |
116 | $self->set_end; |
172 | $self->set_end; |
117 | } |
173 | } |
118 | |
174 | |
119 | sub do_command { |
175 | sub tag_enterleave { |
120 | my ($self, $cmd, $arg, %arg) = @_; |
176 | my ($self, $tag, $content) = @_; |
|
|
177 | |
|
|
178 | my $cur = $self->{current_tag}; |
|
|
179 | |
|
|
180 | if ($cur->[0] != $tag || $cur->[1] ne $content) { |
|
|
181 | $self->signal_emit (leave_tag => @$cur) if $cur->[0]; |
|
|
182 | $self->{current_tag} = $cur = [$tag, $content]; |
|
|
183 | $self->signal_emit (enter_tag => @$cur) if $cur->[0]; |
|
|
184 | } |
|
|
185 | } |
|
|
186 | |
|
|
187 | sub tag_event { |
|
|
188 | my ($self, $tag, $event, $content) = @_; |
|
|
189 | |
|
|
190 | return unless $self->{app}; |
|
|
191 | |
|
|
192 | if ($tag eq "user" && $event->type eq "button-release") { |
|
|
193 | if ($event->button == 1) { |
|
|
194 | $content =~ /^([^\x20\xa0]+)/ or return; |
|
|
195 | $self->{app}->open_user (name => $1); |
|
|
196 | } |
|
|
197 | } |
121 | } |
198 | } |
122 | |
199 | |
123 | sub set_end { |
200 | sub set_end { |
124 | my ($self) = @_; |
201 | my ($self) = @_; |
125 | |
202 | |
… | |
… | |
266 | |
343 | |
267 | $widget->show_all; |
344 | $widget->show_all; |
268 | |
345 | |
269 | my $anchor = $self->{buffer}->create_child_anchor ($self->riter); |
346 | my $anchor = $self->{buffer}->create_child_anchor ($self->riter); |
270 | $self->{parent}{view}->add_child_at_anchor ($widget, $anchor); |
347 | $self->{parent}{view}->add_child_at_anchor ($widget, $anchor); |
|
|
348 | |
|
|
349 | $widget; |
271 | } |
350 | } |
272 | |
351 | |
273 | sub append_optionmenu { |
352 | sub append_optionmenu { |
274 | my ($self, $ref, @entry) = @_; |
353 | my ($self, $ref, @entry) = @_; |
275 | |
354 | |
276 | my @vals; |
355 | $self->append_widget (gtk::optionmenu $ref, @entry); |
277 | |
|
|
278 | my $widget = new Gtk2::OptionMenu; |
|
|
279 | $widget->set (menu => my $menu = new Gtk2::Menu); |
|
|
280 | |
|
|
281 | my $idx = 0; |
|
|
282 | |
|
|
283 | while (@entry >= 2) { |
|
|
284 | my $value = shift @entry; |
|
|
285 | my $label = shift @entry; |
|
|
286 | |
|
|
287 | $menu->append (new Gtk2::MenuItem $label); |
|
|
288 | push @vals, $value; |
|
|
289 | |
|
|
290 | if ($value eq $$ref && $idx >= 0) { |
|
|
291 | $widget->set_history ($idx); |
|
|
292 | $idx = -1e6; |
|
|
293 | } |
|
|
294 | $idx++; |
|
|
295 | } |
|
|
296 | |
|
|
297 | my $cb = shift @entry; |
|
|
298 | |
|
|
299 | $widget->signal_connect (changed => sub { |
|
|
300 | my $new = $vals[$_[0]->get_history]; |
|
|
301 | |
|
|
302 | if ($new ne $$ref) { |
|
|
303 | $$ref = $new; |
|
|
304 | $cb->($new) if $cb; |
|
|
305 | } |
|
|
306 | }); |
|
|
307 | |
|
|
308 | $self->append_widget ($widget); |
|
|
309 | |
|
|
310 | $widget; |
|
|
311 | } |
|
|
312 | |
|
|
313 | sub append_entry { |
|
|
314 | my ($self, $ref, $width, $cb) = @_; |
|
|
315 | |
|
|
316 | my $widget = new Gtk2::Entry; |
|
|
317 | $widget->set (text => $$ref, width_chars => $width); |
|
|
318 | eval { $widget->set (xalign => 1) }; # workaround für 2.2 |
|
|
319 | $widget->signal_connect (changed => sub { |
|
|
320 | $$ref = $_[0]->get_text; |
|
|
321 | $cb->($$ref) if $cb; |
|
|
322 | }); |
|
|
323 | |
|
|
324 | $self->append_widget ($widget); |
|
|
325 | $widget; |
|
|
326 | } |
356 | } |
327 | |
357 | |
328 | sub append_button { |
358 | sub append_button { |
329 | my ($self, $label, $cb) = @_; |
359 | my ($self, $label, $cb) = @_; |
330 | |
360 | |
331 | my $widget = new_with_label Gtk2::Button $label; |
361 | $self->append_widget (gtk::button $label, $cb); |
332 | $widget->signal_connect (clicked => sub { $cb->() if $cb }); |
|
|
333 | |
|
|
334 | $self->append_widget ($widget); |
|
|
335 | $widget; |
|
|
336 | } |
362 | } |
337 | |
363 | |
338 | sub visible { $_[0]{visible} } |
364 | sub visible { $_[0]{visible} } |
339 | |
365 | |
340 | sub set_visible { |
366 | sub set_visible { |