Mercurial > repo
view interps/clc-intercal/CLC-INTERCAL-UI-X-1.-94.-2/INTERCAL/Interface/X.pm @ 12512:9b31bb5d9ee1 draft default tip
<int-e> learn The password of the month is a matter of ongoing investigations
author | HackEso <hackeso@esolangs.org> |
---|---|
date | Wed, 25 Sep 2024 19:54:44 +0100 |
parents | 859f9b4339e6 |
children |
line wrap: on
line source
package Language::INTERCAL::Interface::X; # Graphical (Gtk2) interface for sick and intercalc # This file is part of CLC-INTERCAL # Copyright (c) 2006-2008 Claudio Calvelli, all rights reserved. # CLC-INTERCAL is copyrighted software. However, permission to use, modify, # and distribute it is granted provided that the conditions set out in the # licence agreement are met. See files README and COPYING in the distribution. use strict; use vars qw($VERSION $PERVERSION); ($VERSION) = ($PERVERSION = "CLC-INTERCAL/UI-X INTERCAL/Interface/X.pm 1.-94.-2") =~ /\s(\S+)$/; use Carp; use Gtk2; use Language::INTERCAL::Exporter '1.-94.-2'; use Language::INTERCAL::Interface::common '1.-94.-2'; use vars qw(@ISA); @ISA = qw(Language::INTERCAL::Interface::common); my %keymap = ( ' ' => 'space', '!' => 'exclam', '"' => 'quotedbl', '#' => 'numbersign', "'" => 'apostrophe', '$' => 'dollar', '%' => 'percent', '&' => 'ampersand', '(' => 'parenleft', ')' => 'parenright', '*' => 'asterisk', '+' => 'plus', ',' => 'comma', '-' => 'minus', '.' => 'period', '/' => 'slash', ':' => 'colon', ';' => 'semicolon', '<' => 'less', '=' => 'equal', '>' => 'greater', '?' => 'question', '@' => 'at', '[' => 'bracketleft', '\\' => 'backslash', ']' => 'bracketright', '^' => 'asciicircum', '_' => 'underscore', '`' => 'grave', '{' => 'braceleft', '|' => 'bar', '}' => 'braceright', '~' => 'asciitilde', '¢' => 'cent', '¥' => 'yen', 'Enter' => 'KP_Enter', ); sub new { @_ == 2 or croak "Usage: Language::INTERCAL::Interface::X->new(SERVER)"; my ($class, $server) = @_; $server or croak "Must provide SERVER"; $ENV{DISPLAY} or return undef; Gtk2->init(); # XXX there's probably a better way of doing this Glib::Timeout->add(100, sub { $server->progress(0); 1 }); my $toplevel = Gtk2::Window->new(); my $X = bless { keylist => {}, wid => 0, toplevel => $toplevel, topused => 0, }, $class; $X->_initialise; $X; } sub has_window { 1 } sub is_interactive { 1 } sub is_terminal { 1 } sub can_paste { 1 } sub stdread { croak "X interface should not use stdread directly"; } sub getline { @_ == 2 or croak "Usage: X->getline(PROMPT)"; my ($X, $prompt) = @_; my $d = Gtk2::Dialog->new($prompt, undef, [qw(modal destroy-with-parent)], 'Go ahead' => 'accept', 'Give up' => 'reject'); my $vbox = $d->vbox; my $t = Gtk2::Label->new($prompt); $vbox->add($t); my $e = Gtk2::Entry->new; $vbox->add($e); $e->signal_connect(activate => sub {$d->response('accept')}); $d->show_all; my $resp = $d->run; my $line = undef; if ($resp eq 'accept') { $line = $e->get_text() . "\n"; } $d->destroy; return $line; } sub window { @_ == 4 || @_ == 5 || @_ == 6 or croak "Usage: X->window(NAME, DESTROY, DEFINITION [, MENUS [, ACT]])"; my ($X, $name, $destroy, $def, $menus, $act) = @_; my $window; if ($X->{topused}) { $window = Gtk2::Window->new(); } else { $window = $X->{toplevel}; $window->resize(1, 1); $X->{toplist} = []; } $window->set_title($name); $X->{_accel} = Gtk2::AccelGroup->new(); $X->{_act} = $act; $X->{_alter} = undef; delete $X->{_skip_table}; my $wid = ++$X->{wid}; my $table = undef; if (defined $menus) { $X->{_menubar} = Gtk2::MenuBar->new; $X->_parse_menus($wid, @$menus); $table = Gtk2::Table->new(2, 1); if (! $X->{topused}) { unshift @{$X->{toplist}}, $table; unshift @{$X->{toplist}}, $X->{_menubar}; } $table->set_border_width(0); $table->attach_defaults($X->{_menubar}, 0, 1, 0, 1); $window->add($table); delete $X->{_menubar}; } my $content = $X->_parse_def($wid, @$def); if ($table) { $table->attach_defaults($content->[0], 0, 1, 1, 2); } else { $window->add($content->[0]); } $window->add_accel_group($X->{_accel}); my $alter = $X->{_alter} ? $X->{_alter}[0] : undef; delete $X->{_alter}; delete $X->{_accel}; delete $X->{_act}; my $code; if ($act) { $code = sub { my $res = eval { &$destroy; }; $act->($X, $@ || $res, @_); 1; } } elsif ($destroy) { $code = sub { &$destroy; 0; } } else { $code = sub { 1 }; } $window->signal_connect(delete_event => $code); $window->show_all; $X->{topused} = 1; [$window, $wid, $alter]; } sub alter_data { @_ == 3 or croak "Usage: X->alter_data(WINDOW, DATA)"; my ($X, $window, $data) = @_; $window->[2] or croak "Not alterable"; my $table = $window->[2]; $X->{_alter} = undef; $X->{_skip_table} = 1; my $content = $X->_parse_def(0, @$data); $X->{_alter} or croak "Must provide a new alterable item"; my @goner = $table->get_children; for my $goner (@goner) { $table->remove($goner); } my ($newtable, $newrows, $newcols, $newelements) = @{$X->{_alter}}; delete $X->{_alter}; delete $X->{_skip_table}; $table->resize($newrows, $newcols); for my $te (@$newelements) { my ($e, $c0, $c1, $r0, $r1) = @$te; $table->attach_defaults($e->[0], $c0, $c1, $r0, $r1); } $table->show_all; $X; } sub show { @_ == 2 or croak "Usage: X->show(WINDOW)"; my ($X, $window) = @_; $window->[0]->set_keep_above(1); $window->[0]->deiconify; $window->[0]->show_all; $window->[0]->set_keep_above(0); $window; } sub start { @_ == 1 or croak "Usage: X->start"; my ($X) = @_; Gtk2->main_iteration() while Gtk2->events_pending(); } sub run { @_ == 1 or croak "Usage: X->run"; my ($X) = @_; Gtk2->main; } sub stop { @_ == 1 or croak "Usage: X->stop"; my ($X) = @_; Gtk2->main_quit if Gtk2->main_level > 0; } sub pending_events { @_ == 1 or croak "Usage: X->pending_events"; return 0; # XXX return Gtk2->events_pending(); } sub update { @_ == 1 or croak "Usage: X->update"; my ($X) = @_; Gtk2->main_iteration() while Gtk2->events_pending(); } sub has_paste { @_ == 1 or croak "Usage: X->has_paste"; my ($X) = @_; my $clipboard = Gtk2::Clipboard->get(Gtk2::Gdk::Atom->new('PRIMARY')); return $clipboard->wait_is_text_available; } sub do_paste { @_ == 1 or croak "Usage: X->do_paste"; my ($X) = @_; my $clipboard = Gtk2::Clipboard->get(Gtk2::Gdk::Atom->new('PRIMARY')); $clipboard->wait_is_text_available or return; my $text = $clipboard->wait_for_text; while ($text ne '') { my $k = substr($text, 0, 1, ''); &{$X->{keylist}{$k}} if exists $X->{keylist}{$k}; Gtk2->main_iteration() while Gtk2->events_pending(); } } sub _set_text { my ($X, $text, $value) = @_; $text->[0]->set_label($value); } sub _get_text { @_ == 2 or croak "Usage: X->get_text(NAME)"; my ($X, $text) = @_; $text->[0]->get_label(); } sub close { @_ == 2 or croak "Usage: X->close(WINDOW)"; my ($X, $window) = @_; if ($window->[0] == $X->{toplevel}) { # we never close the main window - otherwise when they change mode # or reload the compiler the main window gets closed and may be # reopened in a different screen / location which I find annoying # and I assume other people may find annoying too. $_->destroy for @{$X->{toplist}}; $X->{topused} = 0; } else { $X->_close($window->[1]); $window->[0]->destroy; } } sub enable { @_ == 2 or croak "Usage: X->enable(BUTTON)"; my ($X, $button) = @_; ref $button->[1] or die "Cannot enable this element\n"; $button->[0]->set_relief('normal'); ${$button->[1]} = 1; } sub disable { @_ == 2 or croak "Usage: X->disable(BUTTON)"; my ($X, $button) = @_; ref $button->[1] or die "Cannot disable this element\n"; $button->[0]->set_relief('none'); ${$button->[1]} = 0; } sub file_dialog { @_ == 5 or croak "Usage: X->file_dialog(TITLE, NEW?, OK, CANCEL)"; my ($X, $title, $new, $ok, $cancel) = @_; my $window = Gtk2::Window->new(); my @acts = ( (defined $new ? 'save' : 'open'), $ok => 'accept', $cancel => 'cancel', ); my $dialog = Gtk2::FileChooserDialog->new($title, $window, @acts); $new and $dialog->set_filename($new); my $resp = $dialog->run; my $file = undef; if ($resp eq 'accept') { $file = $dialog->get_filename; } $dialog->destroy; $file; } sub _make_table { my ($X, $rows, $cols, $elements, $border, $alter) = @_; my $table = $alter && $X->{_skip_table} ? undef : Gtk2::Table->new($rows, $cols); unshift @{$X->{toplist}}, $table if ! $X->{topused}; $X->{_alter} = [$table, $rows, $cols, $elements] if $alter; defined $table or return [0, 0]; $table->set_border_width($border); for my $te (@$elements) { my ($e, $c0, $c1, $r0, $r1) = @$te; $table->attach_defaults($e->[0], $c0, $c1, $r0, $r1); } [$table, 0]; } sub _make_text { my ($X, $value, $align, $size) = @_; my $text = Gtk2::Label->new($value); unshift @{$X->{toplist}}, $text if ! $X->{topused}; $text->set_width_chars($size) if $size; $text->set_max_width_chars($size) if $size; $text->set_alignment(0.0, 0.0) if $align =~ /^l/i; $text->set_alignment(0.5, 0.0) if $align =~ /^c/i; $text->set_alignment(1.0, 0.0) if $align =~ /^r/i; [$text, 0]; } sub _make_key { my ($X, $label, $action, $keys) = @_; my $key = Gtk2::Button->new_with_label($label); unshift @{$X->{toplist}}, $key if ! $X->{topused}; my $acode; my $enabled = 1; if ($X->{_act}) { my $act = $X->{_act}; $acode = sub { $@ = ''; $enabled or return; my $res = eval { $action->(@_); }; $act->($X, $@ || $res, @_); }; } else { $acode = sub { $@ = ''; $enabled or return; $action->(@_); }; } $key->signal_connect(clicked => $acode); for my $k (@$keys) { $X->{keylist}{$k} = $action; $k =~ s/^([\c@-\c_])$/sprintf("<control>%c", 64 + ord($1))/e; $k =~ s/^([A-Z])$/sprintf("<shift>%c", 32 + ord($1))/e; $k = $keymap{$k} if exists $keymap{$k}; my ($a, $m) = Gtk2::Accelerator->parse($k); die "k=$k a=$a m=$m\n" if $a == 0; # XXX my $fs = sub { $key->activate }; $X->{_accel}->connect($a, $m, [], $fs); }; [$key, \$enabled]; } sub _make_menu { my ($X, $name) = @_; my $menu = Gtk2::Menu->new; my $item = Gtk2::MenuItem->new_with_label($name); $item->show; $X->{_menubar}->append($item); $item->set_submenu($menu); [$menu, 0]; } sub _make_menu_entry { my ($X, $action, $menu, $name, $entry, $ticks) = @_; my $item; if ($ticks) { $item = Gtk2::CheckMenuItem->new_with_label($entry); } else { $item = Gtk2::MenuItem->new_with_label($entry); } $menu->[0]->append($item); my $enabled = 1; my $acode; if ($X->{_act}) { my $act = $X->{_act}; $acode = sub { $@ = ''; $enabled or return; my $res = eval { $action->($X, $name, $entry); }; $act->($X, $@ || $res, @_); }; } else { $acode = sub { $enabled or return; $action->($X, $name, $entry); }; } $item->signal_connect(activate => $acode); $item->show; [$item, \$enabled, $ticks]; } sub _enable_menu { my ($X, $item, $state, $name, $entry) = @_; ref $item->[1] or die "Cannot enable this menu\n"; ${$item->[1]} = $state; $state ? $item->[0]->show : $item->[0]->hide; 1; } sub _tick_menu { my ($X, $item, $state, $name, $entry) = @_; $item->[2] or die "Cannot tick this menu\n"; my $ov = ${$item->[1]}; ${$item->[1]} = 0; $item->[0]->set_active($state); ${$item->[1]} = $ov; 1; } sub _menu_action { my ($X, $item, $name, $entry) = @_; $item->activate; } 1;