|
996
|
1 package Language::INTERCAL::Interface::common;
|
|
|
2
|
|
|
3 # Base class for all interface; not to be used directly
|
|
|
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/Base INTERCAL/Interface/common.pm 1.-94.-2") =~ /\s(\S+)$/;
|
|
|
16
|
|
|
17 use Carp;
|
|
|
18 use Language::INTERCAL::Exporter '1.-94.-2';
|
|
|
19
|
|
|
20 sub _initialise {
|
|
|
21 my ($intf) = @_;
|
|
|
22 $intf->{common} = {
|
|
|
23 keylist => [],
|
|
|
24 text => {},
|
|
|
25 };
|
|
|
26 }
|
|
|
27
|
|
|
28 sub _parse_def {
|
|
|
29 my $intf = shift;
|
|
|
30 my $wid = shift;
|
|
|
31 @_ or croak "Invalid empty definition";
|
|
|
32 my $type = lc(shift);
|
|
|
33 if ($type eq 'vstack' || $type eq 'hstack' || $type eq 'table') {
|
|
|
34 my %options = (
|
|
|
35 border => 0,
|
|
|
36 alterable => 0,
|
|
|
37 );
|
|
|
38 $options{columns} = $options{rows} = undef if $type eq 'table';
|
|
|
39 _getoptions($type, \%options, \@_, qw(data));
|
|
|
40 if ($type eq 'table') {
|
|
|
41 defined $options{rows} || defined $options{columns}
|
|
|
42 or croak "Table must specify either rows or columns";
|
|
|
43 defined $options{rows} && defined $options{columns}
|
|
|
44 and croak "Table cannot specify both rows and columns";
|
|
|
45 defined $options{rows} && $options{rows} < 1
|
|
|
46 and croak "Rows must be at least 1";
|
|
|
47 defined $options{columns} && $options{columns} < 1
|
|
|
48 and croak "Columns must be at least 1";
|
|
|
49 } elsif ($type eq 'vstack') {
|
|
|
50 $options{columns} = 1;
|
|
|
51 } else {
|
|
|
52 $options{rows} = 1;
|
|
|
53 }
|
|
|
54 my $div = $options{rows} || $options{columns};
|
|
|
55 @_ % $div
|
|
|
56 and croak "Invalid number of data items, not multiple of $div";
|
|
|
57 my ($rows, $cols, $byrow);
|
|
|
58 if (defined $options{rows}) {
|
|
|
59 $rows = $options{rows};
|
|
|
60 $cols = @_ / $rows;
|
|
|
61 $byrow = 1;
|
|
|
62 } else {
|
|
|
63 $cols = $options{columns};
|
|
|
64 $rows = @_ / $cols;
|
|
|
65 $byrow = 0;
|
|
|
66 }
|
|
|
67 my ($row, $col) = (0, 0);
|
|
|
68 # crude but it does the job; we save the entries then attach
|
|
|
69 # them all at once, after we know which ones are multiline and/or
|
|
|
70 # multicolumn; also, we can adapt the single _make_table method
|
|
|
71 # for different styles of user interface without much effort
|
|
|
72 my @table = ();
|
|
|
73 while (@_) {
|
|
|
74 my $def = shift;
|
|
|
75 if (! ref $def) {
|
|
|
76 if ($def =~ /^l/i) {
|
|
|
77 $col > 0 or croak "Invalid left reference";
|
|
|
78 $table[$col][$row] = $table[$col - 1][$row];
|
|
|
79 $table[$col][$row][2]++;
|
|
|
80 } elsif ($def =~ /^u/i) {
|
|
|
81 $row > 0 or croak "Invalid up reference";
|
|
|
82 $table[$col][$row] = $table[$col][$row - 1];
|
|
|
83 $table[$col][$row][4]++;
|
|
|
84 } else {
|
|
|
85 croak "$def: Invalid multicell entry";
|
|
|
86 }
|
|
|
87 } else {
|
|
|
88 my $e = $intf->_parse_def($wid, @$def);
|
|
|
89 $table[$col][$row] = [$e, $col, $col + 1, $row, $row + 1, 0];
|
|
|
90 }
|
|
|
91 if ($byrow) {
|
|
|
92 $row++;
|
|
|
93 if ($row >= $rows) {
|
|
|
94 $col++;
|
|
|
95 $row = 0;
|
|
|
96 }
|
|
|
97 } else {
|
|
|
98 $col++;
|
|
|
99 if ($col >= $cols) {
|
|
|
100 $row++;
|
|
|
101 $col = 0;
|
|
|
102 }
|
|
|
103 }
|
|
|
104 }
|
|
|
105 # make a list out of this
|
|
|
106 my @t = ();
|
|
|
107 for my $tc (@table) {
|
|
|
108 for my $tr (@$tc) {
|
|
|
109 next if $tr->[5];
|
|
|
110 $tr->[5] = 1;
|
|
|
111 push @t, $tr;
|
|
|
112 }
|
|
|
113 }
|
|
|
114 return $intf->_make_table($rows, $cols, \@t,
|
|
|
115 $options{border},
|
|
|
116 $options{alterable});
|
|
|
117 }
|
|
|
118 if ($type eq 'text') {
|
|
|
119 my %options = (
|
|
|
120 value => '',
|
|
|
121 size => undef,
|
|
|
122 name => undef,
|
|
|
123 align => 'c',
|
|
|
124 );
|
|
|
125 _getoptions($type, \%options, \@_);
|
|
|
126 $options{align} =~ /^[lrc]/i or croak "Invalid align";
|
|
|
127 my $value = $options{value};
|
|
|
128 my $text = $intf->_make_text($value, $options{align}, $options{size});
|
|
|
129 $intf->{common}{text}{$options{name}} =
|
|
|
130 [$text, $options{align}, $options{size}, $wid]
|
|
|
131 if defined $options{name};
|
|
|
132 return $text;
|
|
|
133 }
|
|
|
134 if ($type eq 'key') {
|
|
|
135 my %options = (
|
|
|
136 name => undef,
|
|
|
137 label => undef,
|
|
|
138 key => undef,
|
|
|
139 action => undef,
|
|
|
140 );
|
|
|
141 _getoptions($type, \%options, \@_);
|
|
|
142 defined $options{key} or croak "key must specify a key sequence";
|
|
|
143 defined $options{action} or croak "key must specify action";
|
|
|
144 defined $options{name} or croak "key must specify name";
|
|
|
145 $options{label} = $options{name}
|
|
|
146 if ! defined $options{label};
|
|
|
147 my $action = sub {
|
|
|
148 &{$options{action}}($options{name});
|
|
|
149 };
|
|
|
150 my $k = ref $options{key} ? $options{key} : [$options{key}];
|
|
|
151 my $key = $intf->_make_key($options{label}, $action, $k);
|
|
|
152 push @{$intf->{common}{keylist}},
|
|
|
153 [$key, $options{name}, $k, $options{action}, $wid];
|
|
|
154 return $key;
|
|
|
155 }
|
|
|
156 croak "Invalid definition: type=$type";
|
|
|
157 }
|
|
|
158
|
|
|
159 sub _close {
|
|
|
160 my ($intf, $wid) = @_;
|
|
|
161 @{$intf->{common}{keylist}} =
|
|
|
162 grep { $_->[4] != $wid } @{$intf->{common}{keylist}};
|
|
|
163 my @del = grep { $intf->{common}{text}{$_}[3] == $wid }
|
|
|
164 keys %{$intf->{common}{text}};
|
|
|
165 delete $intf->{common}{text}{$_} for @del;
|
|
|
166 }
|
|
|
167
|
|
|
168 sub _parse_menus {
|
|
|
169 @_ >= 3 or croak "Invalid menu, no entries";
|
|
|
170 my ($intf, $wid, @defs) = @_;
|
|
|
171 my %ticks = ();
|
|
|
172 my %menu = ();
|
|
|
173 my @menu = ();
|
|
|
174 for my $def (@defs) {
|
|
|
175 ref $def && UNIVERSAL::isa($def, 'ARRAY')
|
|
|
176 or croak "Invalid menu spec, must be an ARRAY reference";
|
|
|
177 @$def or croak "Invalid empty menu spec";
|
|
|
178 @$def >= 2 or croak "Invalid menu spec for $def->[0]: no entries";
|
|
|
179 my ($name, @entries) = @$def;
|
|
|
180 exists $menu{$name} and croak "Duplicate menu $name";
|
|
|
181 my $menu = $intf->_make_menu($name);
|
|
|
182 my $ml = [];
|
|
|
183 my %md = ('' => [$menu, $ml]);
|
|
|
184 my @items = ();
|
|
|
185 for my $entry (@entries) {
|
|
|
186 ref $entry && UNIVERSAL::isa($entry, 'ARRAY')
|
|
|
187 or croak "Invalid menu entry (in $name), "
|
|
|
188 . "must be an ARRAY reference";
|
|
|
189 my ($ename, @edata) = @$entry;
|
|
|
190 $ename eq '' and croak "Invalid entry (empty name) in $name";
|
|
|
191 exists $md{$ename} and croak "Duplicate entry $ename (in $name)";
|
|
|
192 my %options = (
|
|
|
193 action => undef,
|
|
|
194 enabled => undef,
|
|
|
195 ticked => undef,
|
|
|
196 );
|
|
|
197 _getoptions('menu', \%options, \@edata);
|
|
|
198 push @items, [$ename, \%options];
|
|
|
199 $ticks{$name} = 1 if defined $options{ticked};
|
|
|
200 }
|
|
|
201 for my $item (@items) {
|
|
|
202 my ($ename, $options) = @$item;
|
|
|
203 my $item = $intf->_make_menu_entry($options->{action},
|
|
|
204 $menu, $name, $ename,
|
|
|
205 $ticks{$name});
|
|
|
206 $md{$ename} = $item;
|
|
|
207 push @$ml, $ename;
|
|
|
208 defined $options->{ticked}
|
|
|
209 and $intf->_tick_menu($item, $options->{ticked}, $name, $ename);
|
|
|
210 defined $options->{enabled}
|
|
|
211 and $intf->_enable_menu($item, $options->{enabled},
|
|
|
212 $name, $ename);
|
|
|
213 }
|
|
|
214 $menu{$name} = \%md;
|
|
|
215 push @menu, $name;
|
|
|
216 }
|
|
|
217 $intf->{common}{menu_hash} = \%menu;
|
|
|
218 $intf->{common}{menu_list} = \@menu;
|
|
|
219 $intf->{common}{menu_ticks} = \%ticks;
|
|
|
220 $intf;
|
|
|
221 }
|
|
|
222
|
|
|
223 sub forall {
|
|
|
224 @_ >= 3 or croak "Usage: INTERFACE->forall(TYPE, CODE, ...)";
|
|
|
225 my $intf = shift;
|
|
|
226 my $type = shift;
|
|
|
227 if ($type eq 'key') {
|
|
|
228 @_ == 1 or croak "Usage: INTERFACE->forall('key', CODE)";
|
|
|
229 my $code = shift;
|
|
|
230 for my $k (@{$intf->{common}{keylist}}) {
|
|
|
231 my ($key, $name, $shortcuts, $action) = @$k;
|
|
|
232 last unless $code->($intf, $key, $name, $action);
|
|
|
233 }
|
|
|
234 } elsif ($type eq 'menu') {
|
|
|
235 @_ == 2 or croak "Usage: INTERFACE->forall('menu', NAME, CODE)";
|
|
|
236 my $name = shift;
|
|
|
237 my $code = shift;
|
|
|
238 exists $intf->{common}{menu_hash}{$name} or croak "Invalid menu $name";
|
|
|
239 my ($menu, $list) = @{$intf->{common}{menu_hash}{$name}{''}};
|
|
|
240 for my $entry (@$list) {
|
|
|
241 last unless $code->($intf, $name, $entry, $menu,
|
|
|
242 $intf->{common}{menu_hash}{$code}{$entry});
|
|
|
243 }
|
|
|
244 } else {
|
|
|
245 croak "Invalid TYPE"; # XXX handle other types
|
|
|
246 }
|
|
|
247 $intf;
|
|
|
248 }
|
|
|
249
|
|
|
250 sub set_text {
|
|
|
251 @_ == 3 or croak "Usage: INTERFACE->set_text(NAME, VALUE)";
|
|
|
252 my ($intf, $name, $value) = @_;
|
|
|
253 exists $intf->{common}{text}{$name} or croak "Unknown NAME $name";
|
|
|
254 if (defined $intf->{common}{text}{$name}[2] &&
|
|
|
255 length $value > $intf->{common}{text}{$name}[2])
|
|
|
256 {
|
|
|
257 if ($intf->{common}{text}{$name}[1] =~ /^l/i) {
|
|
|
258 $value = substr($value, -$intf->{common}{text}{$name}[2]);
|
|
|
259 } else {
|
|
|
260 $value = substr($value, 0, $intf->{common}{text}{$name}[2]);
|
|
|
261 }
|
|
|
262 }
|
|
|
263 $intf->_set_text($intf->{common}{text}{$name}[0], $value);
|
|
|
264 }
|
|
|
265
|
|
|
266 sub get_text {
|
|
|
267 @_ == 2 or croak "Usage: INTERFACE->get_text(NAME)";
|
|
|
268 my ($intf, $name) = @_;
|
|
|
269 exists $intf->{common}{text}{$name} or croak "Unknown NAME";
|
|
|
270 $intf->_get_text($intf->{common}{text}{$name}[0]);
|
|
|
271 }
|
|
|
272
|
|
|
273 sub menu_action {
|
|
|
274 @_ == 3 or croak "Usage: INTERFACE->menu_action(MENU, ENTRY)";
|
|
|
275 my ($intf, $menu, $entry) = @_;
|
|
|
276 my $item = _find_menu($intf, $menu, $entry);
|
|
|
277 $intf->_menu_action($item, $menu, $entry);
|
|
|
278 $intf;
|
|
|
279 }
|
|
|
280
|
|
|
281 sub enable_menu {
|
|
|
282 @_ == 4 or croak "Usage: INTERFACE->enable_menu(STATE, MENU, ENTRY)";
|
|
|
283 my ($intf, $state, $menu, $entry) = @_;
|
|
|
284 my $item = _find_menu($intf, $menu, $entry);
|
|
|
285 $intf->_enable_menu($item, $state, $menu, $entry);
|
|
|
286 $intf;
|
|
|
287 }
|
|
|
288
|
|
|
289 sub tick_menu {
|
|
|
290 @_ == 4 or croak "Usage: INTERFACE->tick_menu(STATE, MENU, ENTRY)";
|
|
|
291 my ($intf, $state, $menu, $entry) = @_;
|
|
|
292 my $item = _find_menu($intf, $menu, $entry);
|
|
|
293 $intf->_tick_menu($item, $state, $menu, $entry);
|
|
|
294 $intf;
|
|
|
295 }
|
|
|
296
|
|
|
297 sub _find_menu {
|
|
|
298 my ($intf, $menu, $entry) = @_;
|
|
|
299 exists $intf->{common}{menu_hash}{$menu}
|
|
|
300 or croak "Invalid menu name: $menu";
|
|
|
301 exists $intf->{common}{menu_hash}{$menu}{$entry}
|
|
|
302 or croak "No such entry in $menu: $entry";
|
|
|
303 $intf->{common}{menu_hash}{$menu}{$entry};
|
|
|
304 }
|
|
|
305
|
|
|
306 sub _getoptions {
|
|
|
307 my ($type, $options, $parms, @stop) = @_;
|
|
|
308 my %stop = map { ($_ => 0) } @stop;
|
|
|
309 while (@$parms) {
|
|
|
310 my $opt = lc(shift @$parms);
|
|
|
311 last if exists $stop{$opt};
|
|
|
312 @$parms or croak "Missing argument to $opt";
|
|
|
313 exists $options->{$opt} or croak "Invalid option for $type: $opt";
|
|
|
314 $options->{$opt} = shift @$parms;
|
|
|
315 }
|
|
|
316 }
|
|
|
317
|
|
|
318 1;
|
