|
996
|
1 package Language::INTERCAL::Interface::X;
|
|
|
2
|
|
|
3 # Graphical (Gtk2) interface for sick and intercalc
|
|
|
4
|
|
|
5 # This file is part of CLC-INTERCAL
|
|
|
6
|
|
|
7 # Copyright (c) 2006-2008 Claudio Calvelli, all rights reserved.
|
|
|
8
|
|
|
9 # CLC-INTERCAL is copyrighted software. However, permission to use, modify,
|
|
|
10 # and distribute it is granted provided that the conditions set out in the
|
|
|
11 # licence agreement are met. See files README and COPYING in the distribution.
|
|
|
12
|
|
|
13 use strict;
|
|
|
14 use vars qw($VERSION $PERVERSION);
|
|
|
15 ($VERSION) = ($PERVERSION = "CLC-INTERCAL/UI-X INTERCAL/Interface/X.pm 1.-94.-2") =~ /\s(\S+)$/;
|
|
|
16
|
|
|
17 use Carp;
|
|
|
18 use Gtk2;
|
|
|
19 use Language::INTERCAL::Exporter '1.-94.-2';
|
|
|
20 use Language::INTERCAL::Interface::common '1.-94.-2';
|
|
|
21 use vars qw(@ISA);
|
|
|
22 @ISA = qw(Language::INTERCAL::Interface::common);
|
|
|
23
|
|
|
24 my %keymap = (
|
|
|
25 ' ' => 'space',
|
|
|
26 '!' => 'exclam',
|
|
|
27 '"' => 'quotedbl',
|
|
|
28 '#' => 'numbersign',
|
|
|
29 "'" => 'apostrophe',
|
|
|
30 '$' => 'dollar',
|
|
|
31 '%' => 'percent',
|
|
|
32 '&' => 'ampersand',
|
|
|
33 '(' => 'parenleft',
|
|
|
34 ')' => 'parenright',
|
|
|
35 '*' => 'asterisk',
|
|
|
36 '+' => 'plus',
|
|
|
37 ',' => 'comma',
|
|
|
38 '-' => 'minus',
|
|
|
39 '.' => 'period',
|
|
|
40 '/' => 'slash',
|
|
|
41 ':' => 'colon',
|
|
|
42 ';' => 'semicolon',
|
|
|
43 '<' => 'less',
|
|
|
44 '=' => 'equal',
|
|
|
45 '>' => 'greater',
|
|
|
46 '?' => 'question',
|
|
|
47 '@' => 'at',
|
|
|
48 '[' => 'bracketleft',
|
|
|
49 '\\' => 'backslash',
|
|
|
50 ']' => 'bracketright',
|
|
|
51 '^' => 'asciicircum',
|
|
|
52 '_' => 'underscore',
|
|
|
53 '`' => 'grave',
|
|
|
54 '{' => 'braceleft',
|
|
|
55 '|' => 'bar',
|
|
|
56 '}' => 'braceright',
|
|
|
57 '~' => 'asciitilde',
|
|
|
58 '¢' => 'cent',
|
|
|
59 '¥' => 'yen',
|
|
|
60 'Enter' => 'KP_Enter',
|
|
|
61 );
|
|
|
62
|
|
|
63 sub new {
|
|
|
64 @_ == 2 or croak "Usage: Language::INTERCAL::Interface::X->new(SERVER)";
|
|
|
65 my ($class, $server) = @_;
|
|
|
66 $server or croak "Must provide SERVER";
|
|
|
67 $ENV{DISPLAY} or return undef;
|
|
|
68 Gtk2->init();
|
|
|
69 # XXX there's probably a better way of doing this
|
|
|
70 Glib::Timeout->add(100, sub { $server->progress(0); 1 });
|
|
|
71 my $toplevel = Gtk2::Window->new();
|
|
|
72 my $X = bless {
|
|
|
73 keylist => {},
|
|
|
74 wid => 0,
|
|
|
75 toplevel => $toplevel,
|
|
|
76 topused => 0,
|
|
|
77 }, $class;
|
|
|
78 $X->_initialise;
|
|
|
79 $X;
|
|
|
80 }
|
|
|
81
|
|
|
82 sub has_window { 1 }
|
|
|
83 sub is_interactive { 1 }
|
|
|
84 sub is_terminal { 1 }
|
|
|
85 sub can_paste { 1 }
|
|
|
86
|
|
|
87 sub stdread {
|
|
|
88 croak "X interface should not use stdread directly";
|
|
|
89 }
|
|
|
90
|
|
|
91 sub getline {
|
|
|
92 @_ == 2 or croak "Usage: X->getline(PROMPT)";
|
|
|
93 my ($X, $prompt) = @_;
|
|
|
94 my $d = Gtk2::Dialog->new($prompt, undef,
|
|
|
95 [qw(modal destroy-with-parent)],
|
|
|
96 'Go ahead' => 'accept',
|
|
|
97 'Give up' => 'reject');
|
|
|
98 my $vbox = $d->vbox;
|
|
|
99 my $t = Gtk2::Label->new($prompt);
|
|
|
100 $vbox->add($t);
|
|
|
101 my $e = Gtk2::Entry->new;
|
|
|
102 $vbox->add($e);
|
|
|
103 $e->signal_connect(activate => sub {$d->response('accept')});
|
|
|
104 $d->show_all;
|
|
|
105 my $resp = $d->run;
|
|
|
106 my $line = undef;
|
|
|
107 if ($resp eq 'accept') {
|
|
|
108 $line = $e->get_text() . "\n";
|
|
|
109 }
|
|
|
110 $d->destroy;
|
|
|
111 return $line;
|
|
|
112 }
|
|
|
113
|
|
|
114 sub window {
|
|
|
115 @_ == 4 || @_ == 5 || @_ == 6
|
|
|
116 or croak "Usage: X->window(NAME, DESTROY, DEFINITION [, MENUS [, ACT]])";
|
|
|
117 my ($X, $name, $destroy, $def, $menus, $act) = @_;
|
|
|
118 my $window;
|
|
|
119 if ($X->{topused}) {
|
|
|
120 $window = Gtk2::Window->new();
|
|
|
121 } else {
|
|
|
122 $window = $X->{toplevel};
|
|
|
123 $window->resize(1, 1);
|
|
|
124 $X->{toplist} = [];
|
|
|
125 }
|
|
|
126 $window->set_title($name);
|
|
|
127 $X->{_accel} = Gtk2::AccelGroup->new();
|
|
|
128 $X->{_act} = $act;
|
|
|
129 $X->{_alter} = undef;
|
|
|
130 delete $X->{_skip_table};
|
|
|
131 my $wid = ++$X->{wid};
|
|
|
132 my $table = undef;
|
|
|
133 if (defined $menus) {
|
|
|
134 $X->{_menubar} = Gtk2::MenuBar->new;
|
|
|
135 $X->_parse_menus($wid, @$menus);
|
|
|
136 $table = Gtk2::Table->new(2, 1);
|
|
|
137 if (! $X->{topused}) {
|
|
|
138 unshift @{$X->{toplist}}, $table;
|
|
|
139 unshift @{$X->{toplist}}, $X->{_menubar};
|
|
|
140 }
|
|
|
141 $table->set_border_width(0);
|
|
|
142 $table->attach_defaults($X->{_menubar}, 0, 1, 0, 1);
|
|
|
143 $window->add($table);
|
|
|
144 delete $X->{_menubar};
|
|
|
145 }
|
|
|
146 my $content = $X->_parse_def($wid, @$def);
|
|
|
147 if ($table) {
|
|
|
148 $table->attach_defaults($content->[0], 0, 1, 1, 2);
|
|
|
149 } else {
|
|
|
150 $window->add($content->[0]);
|
|
|
151 }
|
|
|
152 $window->add_accel_group($X->{_accel});
|
|
|
153 my $alter = $X->{_alter} ? $X->{_alter}[0] : undef;
|
|
|
154 delete $X->{_alter};
|
|
|
155 delete $X->{_accel};
|
|
|
156 delete $X->{_act};
|
|
|
157 my $code;
|
|
|
158 if ($act) {
|
|
|
159 $code = sub {
|
|
|
160 my $res = eval { &$destroy; };
|
|
|
161 $act->($X, $@ || $res, @_);
|
|
|
162 1;
|
|
|
163 }
|
|
|
164 } elsif ($destroy) {
|
|
|
165 $code = sub {
|
|
|
166 &$destroy;
|
|
|
167 0;
|
|
|
168 }
|
|
|
169 } else {
|
|
|
170 $code = sub { 1 };
|
|
|
171 }
|
|
|
172 $window->signal_connect(delete_event => $code);
|
|
|
173 $window->show_all;
|
|
|
174 $X->{topused} = 1;
|
|
|
175 [$window, $wid, $alter];
|
|
|
176 }
|
|
|
177
|
|
|
178 sub alter_data {
|
|
|
179 @_ == 3 or croak "Usage: X->alter_data(WINDOW, DATA)";
|
|
|
180 my ($X, $window, $data) = @_;
|
|
|
181 $window->[2] or croak "Not alterable";
|
|
|
182 my $table = $window->[2];
|
|
|
183 $X->{_alter} = undef;
|
|
|
184 $X->{_skip_table} = 1;
|
|
|
185 my $content = $X->_parse_def(0, @$data);
|
|
|
186 $X->{_alter} or croak "Must provide a new alterable item";
|
|
|
187 my @goner = $table->get_children;
|
|
|
188 for my $goner (@goner) {
|
|
|
189 $table->remove($goner);
|
|
|
190 }
|
|
|
191 my ($newtable, $newrows, $newcols, $newelements) = @{$X->{_alter}};
|
|
|
192 delete $X->{_alter};
|
|
|
193 delete $X->{_skip_table};
|
|
|
194 $table->resize($newrows, $newcols);
|
|
|
195 for my $te (@$newelements) {
|
|
|
196 my ($e, $c0, $c1, $r0, $r1) = @$te;
|
|
|
197 $table->attach_defaults($e->[0], $c0, $c1, $r0, $r1);
|
|
|
198 }
|
|
|
199 $table->show_all;
|
|
|
200 $X;
|
|
|
201 }
|
|
|
202
|
|
|
203 sub show {
|
|
|
204 @_ == 2 or croak "Usage: X->show(WINDOW)";
|
|
|
205 my ($X, $window) = @_;
|
|
|
206 $window->[0]->set_keep_above(1);
|
|
|
207 $window->[0]->deiconify;
|
|
|
208 $window->[0]->show_all;
|
|
|
209 $window->[0]->set_keep_above(0);
|
|
|
210 $window;
|
|
|
211 }
|
|
|
212
|
|
|
213 sub start {
|
|
|
214 @_ == 1 or croak "Usage: X->start";
|
|
|
215 my ($X) = @_;
|
|
|
216 Gtk2->main_iteration() while Gtk2->events_pending();
|
|
|
217 }
|
|
|
218
|
|
|
219 sub run {
|
|
|
220 @_ == 1 or croak "Usage: X->run";
|
|
|
221 my ($X) = @_;
|
|
|
222 Gtk2->main;
|
|
|
223 }
|
|
|
224
|
|
|
225 sub stop {
|
|
|
226 @_ == 1 or croak "Usage: X->stop";
|
|
|
227 my ($X) = @_;
|
|
|
228 Gtk2->main_quit if Gtk2->main_level > 0;
|
|
|
229 }
|
|
|
230
|
|
|
231 sub pending_events {
|
|
|
232 @_ == 1 or croak "Usage: X->pending_events";
|
|
|
233 return 0; # XXX
|
|
|
234 return Gtk2->events_pending();
|
|
|
235 }
|
|
|
236
|
|
|
237 sub update {
|
|
|
238 @_ == 1 or croak "Usage: X->update";
|
|
|
239 my ($X) = @_;
|
|
|
240 Gtk2->main_iteration() while Gtk2->events_pending();
|
|
|
241 }
|
|
|
242
|
|
|
243 sub has_paste {
|
|
|
244 @_ == 1 or croak "Usage: X->has_paste";
|
|
|
245 my ($X) = @_;
|
|
|
246 my $clipboard = Gtk2::Clipboard->get(Gtk2::Gdk::Atom->new('PRIMARY'));
|
|
|
247 return $clipboard->wait_is_text_available;
|
|
|
248 }
|
|
|
249
|
|
|
250 sub do_paste {
|
|
|
251 @_ == 1 or croak "Usage: X->do_paste";
|
|
|
252 my ($X) = @_;
|
|
|
253 my $clipboard = Gtk2::Clipboard->get(Gtk2::Gdk::Atom->new('PRIMARY'));
|
|
|
254 $clipboard->wait_is_text_available or return;
|
|
|
255 my $text = $clipboard->wait_for_text;
|
|
|
256 while ($text ne '') {
|
|
|
257 my $k = substr($text, 0, 1, '');
|
|
|
258 &{$X->{keylist}{$k}} if exists $X->{keylist}{$k};
|
|
|
259 Gtk2->main_iteration() while Gtk2->events_pending();
|
|
|
260 }
|
|
|
261 }
|
|
|
262
|
|
|
263 sub _set_text {
|
|
|
264 my ($X, $text, $value) = @_;
|
|
|
265 $text->[0]->set_label($value);
|
|
|
266 }
|
|
|
267
|
|
|
268 sub _get_text {
|
|
|
269 @_ == 2 or croak "Usage: X->get_text(NAME)";
|
|
|
270 my ($X, $text) = @_;
|
|
|
271 $text->[0]->get_label();
|
|
|
272 }
|
|
|
273
|
|
|
274 sub close {
|
|
|
275 @_ == 2 or croak "Usage: X->close(WINDOW)";
|
|
|
276 my ($X, $window) = @_;
|
|
|
277 if ($window->[0] == $X->{toplevel}) {
|
|
|
278 # we never close the main window - otherwise when they change mode
|
|
|
279 # or reload the compiler the main window gets closed and may be
|
|
|
280 # reopened in a different screen / location which I find annoying
|
|
|
281 # and I assume other people may find annoying too.
|
|
|
282 $_->destroy for @{$X->{toplist}};
|
|
|
283 $X->{topused} = 0;
|
|
|
284 } else {
|
|
|
285 $X->_close($window->[1]);
|
|
|
286 $window->[0]->destroy;
|
|
|
287 }
|
|
|
288 }
|
|
|
289
|
|
|
290 sub enable {
|
|
|
291 @_ == 2 or croak "Usage: X->enable(BUTTON)";
|
|
|
292 my ($X, $button) = @_;
|
|
|
293 ref $button->[1] or die "Cannot enable this element\n";
|
|
|
294 $button->[0]->set_relief('normal');
|
|
|
295 ${$button->[1]} = 1;
|
|
|
296 }
|
|
|
297
|
|
|
298 sub disable {
|
|
|
299 @_ == 2 or croak "Usage: X->disable(BUTTON)";
|
|
|
300 my ($X, $button) = @_;
|
|
|
301 ref $button->[1] or die "Cannot disable this element\n";
|
|
|
302 $button->[0]->set_relief('none');
|
|
|
303 ${$button->[1]} = 0;
|
|
|
304 }
|
|
|
305
|
|
|
306 sub file_dialog {
|
|
|
307 @_ == 5 or croak "Usage: X->file_dialog(TITLE, NEW?, OK, CANCEL)";
|
|
|
308 my ($X, $title, $new, $ok, $cancel) = @_;
|
|
|
309 my $window = Gtk2::Window->new();
|
|
|
310 my @acts = (
|
|
|
311 (defined $new ? 'save' : 'open'),
|
|
|
312 $ok => 'accept',
|
|
|
313 $cancel => 'cancel',
|
|
|
314 );
|
|
|
315 my $dialog = Gtk2::FileChooserDialog->new($title, $window, @acts);
|
|
|
316 $new and $dialog->set_filename($new);
|
|
|
317 my $resp = $dialog->run;
|
|
|
318 my $file = undef;
|
|
|
319 if ($resp eq 'accept') {
|
|
|
320 $file = $dialog->get_filename;
|
|
|
321 }
|
|
|
322 $dialog->destroy;
|
|
|
323 $file;
|
|
|
324 }
|
|
|
325
|
|
|
326 sub _make_table {
|
|
|
327 my ($X, $rows, $cols, $elements, $border, $alter) = @_;
|
|
|
328 my $table = $alter && $X->{_skip_table}
|
|
|
329 ? undef
|
|
|
330 : Gtk2::Table->new($rows, $cols);
|
|
|
331 unshift @{$X->{toplist}}, $table if ! $X->{topused};
|
|
|
332 $X->{_alter} = [$table, $rows, $cols, $elements] if $alter;
|
|
|
333 defined $table or return [0, 0];
|
|
|
334 $table->set_border_width($border);
|
|
|
335 for my $te (@$elements) {
|
|
|
336 my ($e, $c0, $c1, $r0, $r1) = @$te;
|
|
|
337 $table->attach_defaults($e->[0], $c0, $c1, $r0, $r1);
|
|
|
338 }
|
|
|
339 [$table, 0];
|
|
|
340 }
|
|
|
341
|
|
|
342 sub _make_text {
|
|
|
343 my ($X, $value, $align, $size) = @_;
|
|
|
344 my $text = Gtk2::Label->new($value);
|
|
|
345 unshift @{$X->{toplist}}, $text if ! $X->{topused};
|
|
|
346 $text->set_width_chars($size) if $size;
|
|
|
347 $text->set_max_width_chars($size) if $size;
|
|
|
348 $text->set_alignment(0.0, 0.0) if $align =~ /^l/i;
|
|
|
349 $text->set_alignment(0.5, 0.0) if $align =~ /^c/i;
|
|
|
350 $text->set_alignment(1.0, 0.0) if $align =~ /^r/i;
|
|
|
351 [$text, 0];
|
|
|
352 }
|
|
|
353
|
|
|
354 sub _make_key {
|
|
|
355 my ($X, $label, $action, $keys) = @_;
|
|
|
356 my $key = Gtk2::Button->new_with_label($label);
|
|
|
357 unshift @{$X->{toplist}}, $key if ! $X->{topused};
|
|
|
358 my $acode;
|
|
|
359 my $enabled = 1;
|
|
|
360 if ($X->{_act}) {
|
|
|
361 my $act = $X->{_act};
|
|
|
362 $acode = sub {
|
|
|
363 $@ = '';
|
|
|
364 $enabled or return;
|
|
|
365 my $res = eval { $action->(@_); };
|
|
|
366 $act->($X, $@ || $res, @_);
|
|
|
367 };
|
|
|
368 } else {
|
|
|
369 $acode = sub {
|
|
|
370 $@ = '';
|
|
|
371 $enabled or return;
|
|
|
372 $action->(@_);
|
|
|
373 };
|
|
|
374 }
|
|
|
375 $key->signal_connect(clicked => $acode);
|
|
|
376 for my $k (@$keys) {
|
|
|
377 $X->{keylist}{$k} = $action;
|
|
|
378 $k =~ s/^([\c@-\c_])$/sprintf("<control>%c", 64 + ord($1))/e;
|
|
|
379 $k =~ s/^([A-Z])$/sprintf("<shift>%c", 32 + ord($1))/e;
|
|
|
380 $k = $keymap{$k} if exists $keymap{$k};
|
|
|
381 my ($a, $m) = Gtk2::Accelerator->parse($k);
|
|
|
382 die "k=$k a=$a m=$m\n" if $a == 0; # XXX
|
|
|
383 my $fs = sub { $key->activate };
|
|
|
384 $X->{_accel}->connect($a, $m, [], $fs);
|
|
|
385 };
|
|
|
386 [$key, \$enabled];
|
|
|
387 }
|
|
|
388
|
|
|
389 sub _make_menu {
|
|
|
390 my ($X, $name) = @_;
|
|
|
391 my $menu = Gtk2::Menu->new;
|
|
|
392 my $item = Gtk2::MenuItem->new_with_label($name);
|
|
|
393 $item->show;
|
|
|
394 $X->{_menubar}->append($item);
|
|
|
395 $item->set_submenu($menu);
|
|
|
396 [$menu, 0];
|
|
|
397 }
|
|
|
398
|
|
|
399 sub _make_menu_entry {
|
|
|
400 my ($X, $action, $menu, $name, $entry, $ticks) = @_;
|
|
|
401 my $item;
|
|
|
402 if ($ticks) {
|
|
|
403 $item = Gtk2::CheckMenuItem->new_with_label($entry);
|
|
|
404 } else {
|
|
|
405 $item = Gtk2::MenuItem->new_with_label($entry);
|
|
|
406 }
|
|
|
407 $menu->[0]->append($item);
|
|
|
408 my $enabled = 1;
|
|
|
409 my $acode;
|
|
|
410 if ($X->{_act}) {
|
|
|
411 my $act = $X->{_act};
|
|
|
412 $acode = sub {
|
|
|
413 $@ = '';
|
|
|
414 $enabled or return;
|
|
|
415 my $res = eval { $action->($X, $name, $entry); };
|
|
|
416 $act->($X, $@ || $res, @_);
|
|
|
417 };
|
|
|
418 } else {
|
|
|
419 $acode = sub {
|
|
|
420 $enabled or return;
|
|
|
421 $action->($X, $name, $entry);
|
|
|
422 };
|
|
|
423 }
|
|
|
424 $item->signal_connect(activate => $acode);
|
|
|
425 $item->show;
|
|
|
426 [$item, \$enabled, $ticks];
|
|
|
427 }
|
|
|
428
|
|
|
429 sub _enable_menu {
|
|
|
430 my ($X, $item, $state, $name, $entry) = @_;
|
|
|
431 ref $item->[1] or die "Cannot enable this menu\n";
|
|
|
432 ${$item->[1]} = $state;
|
|
|
433 $state ? $item->[0]->show : $item->[0]->hide;
|
|
|
434 1;
|
|
|
435 }
|
|
|
436
|
|
|
437 sub _tick_menu {
|
|
|
438 my ($X, $item, $state, $name, $entry) = @_;
|
|
|
439 $item->[2] or die "Cannot tick this menu\n";
|
|
|
440 my $ov = ${$item->[1]};
|
|
|
441 ${$item->[1]} = 0;
|
|
|
442 $item->[0]->set_active($state);
|
|
|
443 ${$item->[1]} = $ov;
|
|
|
444 1;
|
|
|
445 }
|
|
|
446
|
|
|
447 sub _menu_action {
|
|
|
448 my ($X, $item, $name, $entry) = @_;
|
|
|
449 $item->activate;
|
|
|
450 }
|
|
|
451
|
|
|
452 1;
|
