Mercurial > repo
comparison interps/clc-intercal/CLC-INTERCAL-ICALC-1.-94.-2/bin/intercalc @ 996:859f9b4339e6
<Gregor> tar xf egobot.tar.xz
| author | HackBot |
|---|---|
| date | Sun, 09 Dec 2012 19:30:08 +0000 |
| parents | |
| children |
comparison
equal
deleted
inserted
replaced
| 995:6883f5911eb7 | 996:859f9b4339e6 |
|---|---|
| 1 #!/usr/bin/perl -w | |
| 2 | |
| 3 # Simple INTERCAL desk calculator | |
| 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 require 5.005; | |
| 14 | |
| 15 use strict; | |
| 16 use Getopt::Long; | |
| 17 use IO::File; | |
| 18 use Config '%Config'; | |
| 19 | |
| 20 use vars qw($VERSION $PERVERSION); | |
| 21 ($VERSION) = ($PERVERSION = "CLC-INTERCAL/ICALC bin/intercalc 1.-94.-2") =~ /\s(\S+)$/; | |
| 22 | |
| 23 use Language::INTERCAL::Sick '1.-94.-2'; | |
| 24 use Language::INTERCAL::Rcfile '1.-94.-2'; | |
| 25 use Language::INTERCAL::Interface '1.-94.-2'; | |
| 26 use Language::INTERCAL::Server '1.-94.-2'; | |
| 27 use Language::INTERCAL::ReadNumbers '1.-94.-2', qw(roman roman_type); | |
| 28 | |
| 29 my %roman_ok = map { ( roman_type($_) => 1 ) } qw(CLC ARCHAIC WIMPMODE); | |
| 30 | |
| 31 my %object_types = ( | |
| 32 COMPILER => 'LANGUAGE', | |
| 33 BASE => 'BASE', | |
| 34 EXTENSION => 'OPTION', | |
| 35 OPTION => 'OPTION', | |
| 36 POSTPRE => undef, | |
| 37 ); | |
| 38 | |
| 39 my %menu_defs = ( | |
| 40 LANGUAGE => [ 'Language', \&_change_language, 0 ], | |
| 41 BASE => [ 'Base', \&_change_base, 0 ], | |
| 42 OPTION => [ 'Options', \&_toggle_option, 1 ], | |
| 43 ); | |
| 44 | |
| 45 my %escape_defs = ( | |
| 46 'a' => [\&_about, undef, undef, undef], | |
| 47 'b' => [\&_change_base, 'BASE', undef, 'bases'], | |
| 48 'c' => [\&_sickrc, undef, undef, undef], | |
| 49 'g' => [\&_give_up, undef, undef, undef], | |
| 50 'h' => [\&_history, '0', undef, undef], | |
| 51 'l' => [\&_change_language, 'LANGUAGE', '+', 'languages'], | |
| 52 'm' => [\&_change_mode, '0', undef, undef], | |
| 53 'o' => [\&_toggle_option, 'OPTION', undef, 'options'], | |
| 54 'r' => [\&_read_or_readas, '0', undef, undef], | |
| 55 't' => [\&_trace, '0', undef, undef], | |
| 56 'v' => [\&_version, undef, undef, undef], | |
| 57 'w' => [\&_write_file, '', undef, undef], | |
| 58 '?' => [\&_help, undef, undef, undef], | |
| 59 # secret undocumented escape to be used in an undocumented way | |
| 60 "\0" => [\&_undocumented, undef, undef, undef], | |
| 61 ); | |
| 62 | |
| 63 if (defined &Getopt::Long::Configure) { | |
| 64 Getopt::Long::Configure qw(no_ignore_case auto_abbrev permute bundling); | |
| 65 } else { | |
| 66 $Getopt::Long::ignorecase = 0; | |
| 67 $Getopt::Long::autoabbrev = 1; | |
| 68 $Getopt::Long::order = $Getopt::Long::PERMUTE; | |
| 69 $Getopt::Long::bundling = 1; | |
| 70 } | |
| 71 | |
| 72 my $rcfile = new Language::INTERCAL::Rcfile; | |
| 73 my $compiler = new Language::INTERCAL::Sick($rcfile); | |
| 74 my $setoption = sub { $compiler->setoption(@_) }; | |
| 75 my $language = undef; | |
| 76 my @options = (); | |
| 77 my $mode = undef; | |
| 78 my $user_interface = ''; | |
| 79 my $history = 5; | |
| 80 my @history = (); | |
| 81 my $command = ''; | |
| 82 | |
| 83 GetOptions( | |
| 84 # User Interface Options | |
| 85 'graphic|X' => sub { $user_interface = 'X' }, | |
| 86 'curses|c' => sub { $user_interface = 'Curses' }, | |
| 87 'line' => sub { $user_interface = 'Line' }, | |
| 88 'batch' => sub { $user_interface = 'None' }, | |
| 89 'interface|i=s' => \$user_interface, | |
| 90 # source language and compile options | |
| 91 'bug=i' => $setoption, | |
| 92 'ubug=i' => $setoption, | |
| 93 'include|I=s' => sub { $rcfile->setoption(@_) }, | |
| 94 'language|l=s' => \$language, | |
| 95 'option|o=s' => \@options, | |
| 96 'mode|m=s' => \$mode, | |
| 97 # misc options | |
| 98 'nouserrc' => sub { $rcfile->setoption('nouserrc', 1) }, | |
| 99 'rcfile|r=s' => sub { $rcfile->setoption(@_) }, | |
| 100 ) or usage(); | |
| 101 | |
| 102 $rcfile->load; | |
| 103 | |
| 104 my $savestate = undef; | |
| 105 my $current_file = undef; | |
| 106 if (@ARGV) { | |
| 107 @ARGV == 1 or usage(); | |
| 108 my ($msg, $reload) = load_state($ARGV[0]); | |
| 109 print $msg; | |
| 110 } | |
| 111 | |
| 112 my $base = undef; | |
| 113 my $objects_found = find_objects(); | |
| 114 set_defaults(); | |
| 115 | |
| 116 my $progname = $0; | |
| 117 $progname =~ s#^.*/##; | |
| 118 | |
| 119 my @about_text = ( | |
| 120 "About $progname", | |
| 121 '', | |
| 122 "Distributed with CLC-INTERCAL $VERSION", | |
| 123 ); | |
| 124 | |
| 125 my @copyright = split(/\n/, <<EOC); | |
| 126 Copyright (c) 2006-2008 Claudio Calvelli <intercal\@sdf.lonestar.org> | |
| 127 (Please include the word INTERLEAVING in the subject when emailing that | |
| 128 address, or the email may be ignored) | |
| 129 | |
| 130 In addition to the above, permission is hereby granted to use, misuse, | |
| 131 modify, distribute, break, fix again, etcetera CLC-INTERCAL-$VERSION | |
| 132 provided that the following conditions are met: | |
| 133 | |
| 134 1. Redistributions of source code must retain the above copyright | |
| 135 notice, this list of conditions and the following disclaimer. | |
| 136 2. Redistributions in binary form must reproduce the above copyright | |
| 137 notice, this list of conditions and the following disclaimer in the | |
| 138 documentation and/or other materials provided with the distribution. | |
| 139 3. Neither the name of the Author nor the names of its contributors | |
| 140 may be used to endorse or promote products derived from this software | |
| 141 without specific prior written permission. | |
| 142 | |
| 143 THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND | |
| 144 ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | |
| 145 IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | |
| 146 ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE | |
| 147 FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | |
| 148 DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS | |
| 149 OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) | |
| 150 HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | |
| 151 LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | |
| 152 OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF | |
| 153 SUCH DAMAGE. | |
| 154 EOC | |
| 155 | |
| 156 my @for = ("Help for $progname"); | |
| 157 | |
| 158 my @help_text = split(/\n/, <<'EOH'); | |
| 159 For information about CLC-INTERCAL, please RTFM. | |
| 160 | |
| 161 For information about the calculator, please press | |
| 162 keys at random until you figure out what they do. | |
| 163 | |
| 164 For any other queries, please ask them somewhere else. | |
| 165 | |
| 166 We hope this information helped. Thank you for contacting us. | |
| 167 EOH | |
| 168 | |
| 169 my $server = Language::INTERCAL::Server->new(); | |
| 170 my $ui = Language::INTERCAL::Interface->new($server, | |
| 171 $user_interface, | |
| 172 $rcfile->getitem('SPEAK')); | |
| 173 my $about_object = undef; | |
| 174 my $help_object = undef; | |
| 175 my $trace_object = undef; | |
| 176 my $history_object = undef; | |
| 177 | |
| 178 # End of common initialisations - now run the main loop | |
| 179 my $running = 1; | |
| 180 my %calculator; | |
| 181 _init_calculator(); | |
| 182 my $calcptr = \%calculator; | |
| 183 my $give_up = 0; | |
| 184 my $reserved = 0; | |
| 185 my $memories = undef; | |
| 186 my $main_window = undef; | |
| 187 while ($running) { | |
| 188 create_calculator(); | |
| 189 if (! $ui->has_window) { | |
| 190 run_linemode(); | |
| 191 } else { | |
| 192 run_windowmode(); | |
| 193 } | |
| 194 $calculator{object} && ! defined $savestate | |
| 195 and $savestate = $calculator{object}->get_state(); | |
| 196 } | |
| 197 exit 0; | |
| 198 | |
| 199 sub _init_calculator { | |
| 200 my $read_data = ''; | |
| 201 my $read_fh = Language::INTERCAL::GenericIO->new('STRING', 'r', | |
| 202 \$read_data); | |
| 203 $calculator{read_data} = \$read_data; | |
| 204 $calculator{read_fh} = $read_fh; | |
| 205 my $write_data = ''; | |
| 206 my $write_object = bless \$write_data, 'WOBJ'; | |
| 207 my $write_fh = Language::INTERCAL::GenericIO->new('OBJECT', 'w', | |
| 208 $write_object); | |
| 209 $calculator{write_fh} = $write_fh; | |
| 210 my $trace_object = bless ['', 0], 'TOBJ'; | |
| 211 my $trace_fh = Language::INTERCAL::GenericIO->new('OBJECT', 'r', | |
| 212 $trace_object); | |
| 213 $calculator{trace_object} = $trace_object; | |
| 214 $calculator{trace_fh} = $trace_fh; | |
| 215 $calculator{memory} = []; | |
| 216 } | |
| 217 | |
| 218 sub run_linemode { | |
| 219 $| = 1; | |
| 220 $ui->complete(\&_complete); | |
| 221 my $stdread = $ui->stdread; | |
| 222 my $prompt = $ui->is_interactive || $ui->is_terminal ? 'INTERCALC> ' : ''; | |
| 223 &{$calculator{finish}}(0) if exists $calculator{finish}; | |
| 224 $calculator{running} = 1; | |
| 225 while ($calculator{running}) { | |
| 226 if (exists $calculator{is_wimp} && $calculator{is_wimp}) { | |
| 227 my $msg = make_wimp(); | |
| 228 my $len = 0; | |
| 229 for my $l (@$msg) { | |
| 230 $len = length $l if $len < length $l; | |
| 231 } | |
| 232 my $dash = '=' x $len; | |
| 233 $stdread->read_text("$_\n") for ('', $dash, '', @$msg, '', $dash); | |
| 234 $calculator{is_wimp} = 0; | |
| 235 } | |
| 236 my $line = $ui->getline($prompt); | |
| 237 if (defined $line && $line ne '') { | |
| 238 chomp $line; | |
| 239 next unless $line =~ /\S/; | |
| 240 # check for escapes | |
| 241 if ($line =~ s/^\`\s*//) { | |
| 242 my $res = eval { process_escape($line); }; | |
| 243 $give_up = 0 if $@; | |
| 244 $stdread->read_text($@ ? $@ : $res); | |
| 245 } else { | |
| 246 $command = $line; | |
| 247 _calculate(); | |
| 248 } | |
| 249 } else { | |
| 250 _stop_calculator(); | |
| 251 } | |
| 252 } | |
| 253 } | |
| 254 | |
| 255 sub run_windowmode { | |
| 256 $main_window and $ui->close($main_window); | |
| 257 my @menus = make_menus($ui); | |
| 258 my @interface = make_interface(1); | |
| 259 $main_window = | |
| 260 $ui->window('Calculator', \&_give_up, \@interface, | |
| 261 \@menus, \&_after_action); | |
| 262 if ($calculator{has_memory}) { | |
| 263 $ui->set_text("memory$_", '') for (1..$history, ''); | |
| 264 } | |
| 265 if (@history) { | |
| 266 my $hp = 0; | |
| 267 my $cmd = 0; | |
| 268 for my $hl (@history) { | |
| 269 last if $cmd && $hp > $history; | |
| 270 my ($type, $line) = @$hl; | |
| 271 if ($type eq 'c' && ! $cmd) { | |
| 272 $cmd = 1; | |
| 273 $ui->set_text('command', $line); | |
| 274 } | |
| 275 if ($type eq 'r' && $hp <= $history) { | |
| 276 my $index = $hp || ''; | |
| 277 if ($calculator{has_memory}) { | |
| 278 my $m = ''; | |
| 279 $m = $1 if $line =~ s/^(\S+)\s//; | |
| 280 $ui->set_text("memory$index", $m); | |
| 281 } | |
| 282 $ui->set_text("display$index", $line); | |
| 283 $hp++; | |
| 284 } | |
| 285 } | |
| 286 } | |
| 287 $ui->start(); | |
| 288 &{$calculator{finish}}(1) if exists $calculator{finish}; | |
| 289 _clear_status(); | |
| 290 _enable_keys(); | |
| 291 _tick_menus(); | |
| 292 if (exists $calculator{is_wimp} && $calculator{is_wimp}) { | |
| 293 my $wimp = undef; | |
| 294 _popup(\$wimp, make_wimp(), [], 'WIMP', 0); | |
| 295 $calculator{is_wimp} = 0; | |
| 296 } | |
| 297 $ui->run; | |
| 298 } | |
| 299 | |
| 300 sub create_calculator { | |
| 301 if ($mode =~ /^oic(\d+)?$/i) { | |
| 302 if ($1) { | |
| 303 $memories = $1; | |
| 304 } elsif (! $memories) { | |
| 305 $memories = 100; | |
| 306 } | |
| 307 my $digits = length($memories - 1); | |
| 308 bless $calcptr, 'OIC'; | |
| 309 $calculator{nmems} = $memories; | |
| 310 if (@{$calculator{memory}} < $memories) { | |
| 311 push @{$calculator{memory}}, | |
| 312 (0) x ($memories - @{$calculator{memory}}); | |
| 313 } | |
| 314 $calculator{digits} = $digits; | |
| 315 $calculator{format} = "m%0${digits}d"; | |
| 316 $calculator{regex} = qr/^m(\d{1,$digits})/i; | |
| 317 $calculator{has_memory} = 1; | |
| 318 $calculator{mode} = 'oic'; | |
| 319 $calculator{display_size} = 40; | |
| 320 delete $calculator{finish}; | |
| 321 } else { | |
| 322 $mode =~ /^(?:full|expr)$/i or die "Invalid mode $mode\n"; | |
| 323 $mode = lc($mode); | |
| 324 bless $calcptr, 'INC'; | |
| 325 $calculator{has_memory} = 0; | |
| 326 $calculator{mode} = $mode; | |
| 327 $calculator{display_size} = 48; | |
| 328 $calculator{finish} = \&_finish, | |
| 329 $calculator{cache} = {}; | |
| 330 } | |
| 331 } | |
| 332 | |
| 333 sub load_state { | |
| 334 my ($file) = @_; | |
| 335 my ($data, $m, $l, $b, @h, @o); | |
| 336 eval { | |
| 337 open(STATE, '<', $file) or die "$file: $!\n"; | |
| 338 while (1) { | |
| 339 my $line = <STATE>; | |
| 340 defined $line or die "Invalid object: no magic\n"; | |
| 341 last if $line =~ /__INTERCALC__STATE__/; | |
| 342 } | |
| 343 while (<STATE>) { | |
| 344 chomp; | |
| 345 /DATA/ and last; | |
| 346 /MODE\s+(.*)$/ and $m = $1; | |
| 347 /LANG\s+(.*)$/ and $l = $1; | |
| 348 /BASE\s+(.*)$/ and $b = $1; | |
| 349 /OPTS\s+(.*)$/ and push @o, $1; | |
| 350 /HIST\s+(\S+)\s+(.*)$/ and push @h, [$1, $2]; | |
| 351 } | |
| 352 local $/ = undef; | |
| 353 $data = <STATE>; | |
| 354 close STATE; | |
| 355 $data eq '' && lc($m) ne 'oic' | |
| 356 and die "Invalid object: seems to be truncated\n"; | |
| 357 }; | |
| 358 return ($@, 0) if $@; | |
| 359 $savestate = $data; | |
| 360 $mode = $m; | |
| 361 $language = $l; | |
| 362 @options = @o; | |
| 363 $base = $b; | |
| 364 delete $calculator{need_reload}; | |
| 365 $current_file = $file; | |
| 366 @history = @h; | |
| 367 $history_object and _history_trace('', 0, 1); | |
| 368 $trace_object and _history_trace('', 1, 1); | |
| 369 $file =~ s/^.*\///; | |
| 370 ("Loaded state from $file\n", 1); | |
| 371 } | |
| 372 | |
| 373 sub save_state { | |
| 374 my ($file, $force) = @_; | |
| 375 eval { | |
| 376 my $fm = $force ? O_TRUNC : O_EXCL; | |
| 377 my $fh = IO::File->new($file, O_WRONLY | O_CREAT | $fm, 0777) | |
| 378 or die "$file: $!\n"; | |
| 379 print $fh $Config{sharpbang}, ' ', $Config{sh}, "\n" or die "$file: $!\n" | |
| 380 if $Config{sharpbang}; | |
| 381 my $p = $0; | |
| 382 $p =~ s/^.*blib\/script/$Config{installscript}/; | |
| 383 $p =~ s/'/\\'/g; | |
| 384 print $fh <<EOF or die "$file: $!\n"; | |
| 385 # Generated by intercalc, part of CLC-INTERCAL $VERSION | |
| 386 # Execute this program to restart the calculator | |
| 387 # Do not attempt to edit if you value your sanity | |
| 388 | |
| 389 # Note: this program runs under $Config{sh} and then calls the real calculator | |
| 390 # executable - this is because some system can't use an interpreted program as | |
| 391 # an interpreter; you can, of course, just run "intercalc FILENAME" | |
| 392 | |
| 393 exec '$^X' -w '$p' \$0 | |
| 394 | |
| 395 __END__ | |
| 396 __INTERCALC__STATE__ | |
| 397 MODE $mode | |
| 398 EOF | |
| 399 if ($calculator{loaded}) { | |
| 400 print $fh "BASE $calculator{loaded}{BASE}\n" or die "$file: $!\n"; | |
| 401 print $fh "LANG $calculator{loaded}{LANGUAGE}\n" or die "$file: $!\n"; | |
| 402 print $fh "OPTS $_\n" for keys %{$calculator{loaded}{OPTION}}; | |
| 403 } else { | |
| 404 print $fh "LANG $language\n" or die "$file: $!\n"; | |
| 405 print $fh "BASE $base\n" or die "$file: $!\n"; | |
| 406 print $fh "OPTS $_\n" or die "$file: $!\n" for @options; | |
| 407 } | |
| 408 print $fh "HIST $_->[0] $_->[1]\n" or die "$file: $!\n" for @history; | |
| 409 print $fh "DATA\n" or die "$file: $!\n"; | |
| 410 if ($calculator{object}) { | |
| 411 print $fh $calculator{object}->get_state or die "$file: $!\n"; | |
| 412 } | |
| 413 close $fh; | |
| 414 }; | |
| 415 return $@ if $@; | |
| 416 $current_file = $file; | |
| 417 $file =~ s/^.*\///; | |
| 418 "State saved to $file\n"; | |
| 419 } | |
| 420 | |
| 421 sub set_defaults { | |
| 422 my %prog_options = $rcfile->program_options('INTERCALC'); | |
| 423 | |
| 424 if (! defined $language) { | |
| 425 # see if they have a default language - and use any default options | |
| 426 # specified with it if they don't have any on the command line | |
| 427 if (exists $prog_options{LANGUAGE}) { | |
| 428 @options = grep { ! /^\?/ } @{$prog_options{LANGUAGE}[1]{''}} | |
| 429 if @options == 0; | |
| 430 $language = $prog_options{LANGUAGE}[0]; | |
| 431 } else { | |
| 432 $language = 'sick'; | |
| 433 } | |
| 434 } | |
| 435 | |
| 436 if (! defined $mode) { | |
| 437 # see if they have a default mode | |
| 438 if (exists $prog_options{MODE}) { | |
| 439 $mode = $prog_options{MODE}[0]; | |
| 440 } else { | |
| 441 $mode = 'full'; | |
| 442 } | |
| 443 } | |
| 444 | |
| 445 my %base = map { ($_ => 1) } @{$objects_found->{BASE}}; | |
| 446 my @base = grep { exists $base{$_} } @options; | |
| 447 if (@base) { | |
| 448 $base = pop @base; | |
| 449 @options = grep { ! exists $base{$_} } @options; | |
| 450 } else { | |
| 451 ($base) = sort { $a <=> $b } @{$objects_found->{BASE}}; | |
| 452 } | |
| 453 } | |
| 454 | |
| 455 sub make_wimp { | |
| 456 my $ugly = 69 + int(rand 65467); | |
| 457 my $beautiful = roman($ugly, roman_type('CLC')); | |
| 458 [split(/\n/, <<EOH)]; | |
| 459 You have requested the 'wimp' compiler option. This means that | |
| 460 the display output will use those ugly digits where you could | |
| 461 have some beautiful Roman numerals instead. | |
| 462 | |
| 463 Compare the ugly $ugly with the beautiful $beautiful. | |
| 464 | |
| 465 It also means that you are a WIMP WIMP WIMP WIMP. | |
| 466 | |
| 467 As a penance, write "I AM A WIMP" M (sorry, 1000) times. | |
| 468 EOH | |
| 469 } | |
| 470 | |
| 471 sub make_interface { | |
| 472 my ($complete) = @_; | |
| 473 my @interface = (); | |
| 474 $complete and push @interface, ( | |
| 475 'vstack', border => 2, data => | |
| 476 # title | |
| 477 ['hstack', data => | |
| 478 ['text', value => "CLC-INTERCAL $VERSION", align => 'c'], | |
| 479 ], | |
| 480 # history and display | |
| 481 ['vstack', data => | |
| 482 (map { | |
| 483 ['hstack', data => | |
| 484 ($calculator{has_memory} | |
| 485 ? ['text', value => '', size => 1 + $calculator{digits}, | |
| 486 align => 'l', name => "memory$_"] | |
| 487 : ()), | |
| 488 ['text', value => ' ' x $calculator{display_size}, | |
| 489 align => 'r', name => "display$_"], | |
| 490 ], | |
| 491 } (reverse (1..$history)), ''), | |
| 492 ], | |
| 493 ); | |
| 494 if ($calculator{mode} eq 'oic') { | |
| 495 $complete and push @interface, ( | |
| 496 # command | |
| 497 ['hstack', data => | |
| 498 ['text', value => '', align => 'l', size => 32, name => 'command'], | |
| 499 ], | |
| 500 ); | |
| 501 push @interface, ( | |
| 502 # keyboard | |
| 503 ['table', columns => 4, border => 2, data => | |
| 504 # keyboard - row 1 | |
| 505 ['key', name => 'Give Up', key => [qw(g G)], action => \&_give_up], | |
| 506 'l', | |
| 507 ['key', name => 'About', key => [qw(a A)], action => \&_about], | |
| 508 'l', | |
| 509 # keyboard - row 2 | |
| 510 ['key', name => '7', key => '7', action => \&_addkey], | |
| 511 ['key', name => '8', key => '8', action => \&_addkey], | |
| 512 ['key', name => '9', key => '9', action => \&_addkey], | |
| 513 ['key', name => '?', key => [qw(? h H)], action => \&_help], | |
| 514 # keyboard - row 3 | |
| 515 ['key', name => '4', key => '4', action => \&_addkey], | |
| 516 ['key', name => '5', key => '5', action => \&_addkey], | |
| 517 ['key', name => '6', key => '6', action => \&_addkey], | |
| 518 ['key', name => '<-', key => ["\cH", 'Left', 'BackSpace'], action => \&_delkey], | |
| 519 # keyboard - row 4 | |
| 520 ['key', name => '1', key => '1', action => \&_addkey], | |
| 521 ['key', name => '2', key => '2', action => \&_addkey], | |
| 522 ['key', name => '3', key => '3', action => \&_addkey], | |
| 523 ['key', name => 'C', key => [qw(c C)], action => \&_clear], | |
| 524 # keyboard - row 5 | |
| 525 ['key', name => '.', key => '.', action => \&_addkey], | |
| 526 ['key', name => '0', key => '0', action => \&_addkey], | |
| 527 ['key', name => '-', key => '-', action => \&_addkey], | |
| 528 ['key', name => 'M', key => [qw(m M)], action => \&_addkey], | |
| 529 ], | |
| 530 ); | |
| 531 } elsif ($calculator{mode} eq 'expr') { | |
| 532 $complete and push @interface, ( | |
| 533 # command | |
| 534 ['hstack', data => | |
| 535 ['text', value => '', align => 'l', size => 48, name => 'command'], | |
| 536 ], | |
| 537 ); | |
| 538 push @interface, ( | |
| 539 # keyboard | |
| 540 ['table', border => 2, columns => 7, data => | |
| 541 (map { | |
| 542 ['key', | |
| 543 name => $_, | |
| 544 key => /[a-z]/i ? [lc($_), uc($_)] : $_, | |
| 545 action => \&_addkey] | |
| 546 } ( | |
| 547 qw(. < - S U B Y), # row 1 | |
| 548 qw(: / 7 8 9 ' ¢), # row 2 | |
| 549 ',', qw(\ 4 5 6 " &), # row 3 | |
| 550 qw(; $ 1 2 3 ! V), # row 4 | |
| 551 qw(@ ~ * 0), '#', qw(+ ¥), # row 5 | |
| 552 )), | |
| 553 # row 6 | |
| 554 ['key', name => 'Do It', key => ["\cJ", "\cM", qw(Enter Return Linefeed d D)], action => \&_calculate], | |
| 555 'l', | |
| 556 ['key', name => 'Give Up', key => [qw(g G)], action => \&_give_up], | |
| 557 'l', | |
| 558 'l', | |
| 559 ['key', name => '^', key => '^', action => \&_addkey], | |
| 560 ['key', name => '?', key => '?', action => \&_addkey], | |
| 561 # row 7 | |
| 562 ['key', name => 'Clear', key => [qw(c C)], action => \&_clear], | |
| 563 'l', | |
| 564 ['key', name => 'backspace', key => ["\cH", 'Left', 'BackSpace'], action => \&_delkey], | |
| 565 'l', | |
| 566 'l', | |
| 567 ['key', name => '%', key => '%', action => \&_addkey], | |
| 568 ['key', name => '|', key => '|', action => \&_addkey], | |
| 569 # row 8 | |
| 570 ['key', name => 'Help', key => [qw(h H)], action => \&_help], | |
| 571 'l', | |
| 572 ['key', name => 'About', key => [qw(a A)], action => \&_about], | |
| 573 'l', | |
| 574 'l', | |
| 575 ['key', name => 'space', key => ' ', action => \&_addkey], | |
| 576 'l', | |
| 577 ], | |
| 578 ); | |
| 579 } else { | |
| 580 $complete and push @interface, ( | |
| 581 # command | |
| 582 ['hstack', data => | |
| 583 ['text', value => '', align => 'l', size => 49, name => 'command'], | |
| 584 ], | |
| 585 ); | |
| 586 push @interface, ( | |
| 587 # keyboard | |
| 588 ['table', border => 2, columns => 8, data => | |
| 589 (map { | |
| 590 ['key', | |
| 591 name => $_, | |
| 592 key => /[a-z]/i ? [lc($_), uc($_)] : $_, | |
| 593 action => \&_addkey] | |
| 594 } ( | |
| 595 qw(. 0 1 2 3 4), '#', qw(<), | |
| 596 qw(: 5 6 7 8 9 + -), | |
| 597 ',', qw(A B C D E ' "), | |
| 598 qw(; F G H I J), '(', ')', | |
| 599 qw(@ K L M N O [ ]), | |
| 600 qw(% P Q R S T ! *), | |
| 601 qw(^ U V W X Y & |), | |
| 602 qw($ Z / \ ~ ¢ ¥ ?), | |
| 603 )), | |
| 604 ['key', name => 'F1: Help', key => 'F1', action => \&_help], | |
| 605 'l', | |
| 606 ['key', name => 'space', key => ' ', action => \&_addkey], | |
| 607 'l', | |
| 608 ['key', name => 'backspace', key => ["\cH", 'Left', 'BackSpace'], action => \&_delkey], | |
| 609 'l', | |
| 610 ['key', name => 'F2: About', key => 'F2', action => \&_about], | |
| 611 'l', | |
| 612 ['key', name => 'F3: Give Up', key => 'F3', action => \&_give_up], | |
| 613 'l', | |
| 614 ['key', name => 'F4: Clear', key => 'F4', action => \&_clear], | |
| 615 'l', | |
| 616 ['key', name => 'F5: Do It', key => ["\cJ", "\cM", qw(Enter Return Linefeed F5)], action => \&_calculate], | |
| 617 'l', | |
| 618 ['key', name => 'F6: Res\'d', key => 'F6', action => \&_reserved], | |
| 619 'l', | |
| 620 ], | |
| 621 ); | |
| 622 } | |
| 623 @interface; | |
| 624 } | |
| 625 | |
| 626 sub find_objects { | |
| 627 my %of = (); | |
| 628 my $code = sub { | |
| 629 my ($name, $file, $type, $object) = @_; | |
| 630 exists $object_types{uc($type)} or return; | |
| 631 my $ot = $object_types{uc($type)}; | |
| 632 defined $ot or return; | |
| 633 $of{$ot}{$name} = 1; | |
| 634 }; | |
| 635 $compiler->all_objects($code, 1); | |
| 636 my %ol = map { ($_ => [sort keys %{$of{$_}}]) } keys %of; | |
| 637 $ol{MODE} = [qw(Expr Full OIC)]; | |
| 638 return \%ol; | |
| 639 } | |
| 640 | |
| 641 sub process_escape { | |
| 642 my ($line) = @_; | |
| 643 $line =~ s/^(.)\s*// or die "Invalid escape\n"; | |
| 644 my $esc = lc($1); | |
| 645 exists $escape_defs{$esc} or die "Invalid escape `$esc\n"; | |
| 646 $line =~ s/\s+$//; | |
| 647 my ($action, $list, $term, $names) = @{$escape_defs{$esc}}; | |
| 648 if ($line ne '' && ! defined $list) { | |
| 649 die "Escape `$esc does not take arguments\n"; | |
| 650 } | |
| 651 my $menu = $names; | |
| 652 my $multi = 0; | |
| 653 if ($list) { | |
| 654 my $_a; | |
| 655 ($menu, $_a, $multi) = @{$menu_defs{$list}}; | |
| 656 } | |
| 657 if ($line eq '' && defined $list) { | |
| 658 $list eq '' and die "Escape `$esc requires an argument\n"; | |
| 659 if ($list) { | |
| 660 my $loaded = $calculator{need_reload} | |
| 661 || $calculator{loaded} | |
| 662 || {}; | |
| 663 my @l = map { | |
| 664 my $star = | |
| 665 ($multi ? (exists $loaded->{$list}{$_}) | |
| 666 : ($_ eq ($loaded->{$list} || ''))) | |
| 667 ? '*' | |
| 668 : ''; | |
| 669 $star . $_; | |
| 670 } @{$objects_found->{$list}}; | |
| 671 return "Available $names: " . join(', ', @l) . "\n"; | |
| 672 } | |
| 673 } | |
| 674 if ($list) { | |
| 675 my $n = lc($list); | |
| 676 my $data = $line; | |
| 677 if (defined $term) { | |
| 678 my $i = index($line, $term); | |
| 679 $data = substr($line, 0, $i) if $i >= 0; | |
| 680 } | |
| 681 grep { $data eq $_ } @{$objects_found->{$list}} | |
| 682 or return "Invalid $n: $data\n"; | |
| 683 } | |
| 684 $action->($ui, $menu, $line); | |
| 685 } | |
| 686 | |
| 687 sub make_menus { | |
| 688 my ($ui) = @_; | |
| 689 my @menus = ( | |
| 690 [ File => | |
| 691 [ 'Write In', action => \&_write, enabled => 1 ], | |
| 692 [ 'Read Out', action => \&_read, enabled => 0 ], | |
| 693 [ 'Read As', action => \&_read_as, enabled => 1 ], | |
| 694 [ 'Give Up', action => \&_give_up, enabled => 1 ], | |
| 695 ], | |
| 696 [ Edit => | |
| 697 [ 'Backspace', action => \&_delkey, enabled => 0, ], | |
| 698 ($ui->can_paste | |
| 699 ? ([ 'Paste', action => \&_paste, enabled => 1, ]) | |
| 700 : () | |
| 701 ), | |
| 702 [ 'Save settings', action => \&_sickrc, enabled => 1 ], | |
| 703 ], | |
| 704 ); | |
| 705 for my $key (qw(LANGUAGE BASE OPTION)) { | |
| 706 exists $menu_defs{$key} or next; | |
| 707 my ($name, $action, $multi) = @{$menu_defs{$key}}; | |
| 708 push @menus, | |
| 709 [ $name => | |
| 710 map { | |
| 711 [ $_, action => $action, enabled => 1, ticked => 0, ] | |
| 712 } @{$objects_found->{$key}}, | |
| 713 ]; | |
| 714 } | |
| 715 push @menus, | |
| 716 [ Mode => | |
| 717 map { | |
| 718 my $ticked = lc($_) eq lc($mode); | |
| 719 [ $_, action => \&_change_mode, enabled => 1, ticked => $ticked ] | |
| 720 } @{$objects_found->{MODE}}, | |
| 721 ], | |
| 722 [ Window => | |
| 723 [ 'About', action => \&_about, enabled => 1 ], | |
| 724 [ 'Help', action => \&_help, enabled => 1 ], | |
| 725 [ 'History', action => \&_history_w, enabled => 1 ], | |
| 726 [ 'Trace', action => \&_trace_w, enabled => 1 ], | |
| 727 ]; | |
| 728 @menus; | |
| 729 } | |
| 730 | |
| 731 sub _tick_menus { | |
| 732 for my $key (qw(LANGUAGE BASE OPTION)) { | |
| 733 exists $menu_defs{$key} or next; | |
| 734 my $loaded = $calculator{loaded}{$key}; | |
| 735 my ($name, $action, $multi) = @{$menu_defs{$key}}; | |
| 736 for my $obj (@{$objects_found->{$key}}) { | |
| 737 my $t = $multi ? (exists $loaded->{$obj}) : ($obj eq $loaded); | |
| 738 $ui->tick_menu($t, $name, $obj); | |
| 739 } | |
| 740 } | |
| 741 for my $obj (@{$objects_found->{MODE}}) { | |
| 742 $ui->tick_menu(lc($mode) eq lc($obj), 'Mode', $obj); | |
| 743 } | |
| 744 } | |
| 745 | |
| 746 sub _finish { | |
| 747 my ($haswindow) = @_; | |
| 748 my $status = $haswindow | |
| 749 ? sub { _status(shift); $ui->update() } | |
| 750 : sub { $ui->stdread->read_text(shift() . "\n") }; | |
| 751 my $msg = 'Loading'; | |
| 752 if ($calculator{object} && ! $calculator{full_restart}) { | |
| 753 my $loaded = $calculator{need_reload} || $calculator{loaded}; | |
| 754 $language = $loaded->{LANGUAGE}; | |
| 755 $base = $loaded->{BASE}; | |
| 756 $calculator{loaded} = { | |
| 757 LANGUAGE => $language, | |
| 758 BASE => $base, | |
| 759 OPTION => $loaded->{OPTION}, | |
| 760 }; | |
| 761 delete $calculator{need_reload}; | |
| 762 delete $calculator{full_restart}; | |
| 763 my $obj = $calculator{object}; | |
| 764 $calculator{s_line} = | |
| 765 $obj->getreg($calculator{mode} eq 'full' ? 'FS' : 'ES')->number; | |
| 766 return; | |
| 767 } | |
| 768 if ($calculator{need_reload}) { | |
| 769 $language = $calculator{need_reload}{LANGUAGE}; | |
| 770 $base = $calculator{need_reload}{BASE}; | |
| 771 @options = keys %{$calculator{need_reload}{OPTION}}; | |
| 772 delete $calculator{need_reload}; | |
| 773 delete $calculator{full_restart}; | |
| 774 $msg = 'Reloading'; | |
| 775 } | |
| 776 delete $calculator{full_restart}; | |
| 777 $status->("$msg compiler (" . join(', ', $language, $base, @options) . ")"); | |
| 778 my $old_object = $calculator{object}; | |
| 779 eval { | |
| 780 $compiler->reset(); | |
| 781 my $old_server = $old_object ? $old_object->theft_server : undef; | |
| 782 delete $calculator{object}; | |
| 783 $calculator{loaded} = { | |
| 784 LANGUAGE => undef, | |
| 785 BASE => undef, | |
| 786 OPTION => {}, | |
| 787 }; | |
| 788 $calculator{trace_object}->enable(0); | |
| 789 $compiler->setoption('trace_fh', $calculator{trace_fh}); | |
| 790 $compiler->setoption('trace', 0); | |
| 791 $compiler->setoption('preload_callback', [\&_preload_callback]); | |
| 792 $compiler->setoption('default_charset', $_) | |
| 793 for $rcfile->getitem('WRITE'); | |
| 794 $compiler->setoption('default_backend', 'Run'); | |
| 795 $compiler->clearoption('preload'); | |
| 796 $compiler->setoption('preload', $language); | |
| 797 $compiler->setoption('preload', $base); | |
| 798 $compiler->setoption('preload', $_) for @options; | |
| 799 $compiler->source('null.iacc'); | |
| 800 $compiler->server($server); | |
| 801 $compiler->theft_server($old_server); | |
| 802 $compiler->load_objects(); | |
| 803 delete $calculator{need_reload}; | |
| 804 my $obj = $compiler->get_object('null.iacc') | |
| 805 or die "Internal error: no compiler object\n"; | |
| 806 exists $calculator{loaded}{LANGUAGE} | |
| 807 or die "Internal error: no compiler loaded\n"; | |
| 808 $calculator{loaded}{BASE} | |
| 809 or _preload_callback($compiler, $base); | |
| 810 exists $calculator{loaded}{OPTION} | |
| 811 or $calculator{loaded}{OPTION} = {}; | |
| 812 # we need to run null.iacc (even though it doesn't do anything) | |
| 813 # to initialise the interpreter | |
| 814 $obj->start(0)->run()->stop(); | |
| 815 $calculator{object} = $obj; | |
| 816 $calculator{parser} = $obj->{object}->parser(1); | |
| 817 $calculator{s_space} = $obj->getreg('SS')->number; | |
| 818 $calculator{s_statement} = $obj->getreg('PS')->number; | |
| 819 $calculator{s_line} = | |
| 820 $obj->getreg($calculator{mode} eq 'full' ? 'FS' : 'ES')->number; | |
| 821 $obj->setreg('ORFH', $calculator{read_fh}); | |
| 822 $obj->setreg('OSFH', $calculator{read_fh}); | |
| 823 $obj->setreg('OWFH', $calculator{write_fh}); | |
| 824 $obj->setreg('TRFH', $calculator{trace_fh}); | |
| 825 $obj->theft_callback(\&_being_robbed); | |
| 826 my $rt = $obj->getreg('RT')->number; | |
| 827 if (! exists $roman_ok{$rt}) { | |
| 828 $obj->setreg('RT', 'CLC'); | |
| 829 } | |
| 830 $calculator{is_wimp} = 1 | |
| 831 if ! exists $calculator{is_wimp} && $obj->getreg('WT')->number; | |
| 832 $savestate and $obj->set_state($savestate, 0); | |
| 833 $savestate = undef; | |
| 834 $obj->record_grammar(1); | |
| 835 $calculator{trace_object}->enable(1); | |
| 836 $status->("Done \L$msg compiler"); | |
| 837 }; | |
| 838 if ($@) { | |
| 839 my $e = $haswindow ? _shorten($@) : $@; | |
| 840 $status->($e); | |
| 841 if ($old_object) { | |
| 842 $calculator{object} = $old_object; | |
| 843 } else { | |
| 844 sleep 2 if $ui->has_window; | |
| 845 exit 1; | |
| 846 } | |
| 847 } | |
| 848 } | |
| 849 | |
| 850 sub _shorten { | |
| 851 my ($e) = @_; | |
| 852 # make the message as short as possible to fit in the status line | |
| 853 $e =~ s/\s+/ /g; | |
| 854 $e =~ s/^ //; | |
| 855 $e =~ s/[ \.]+$//; | |
| 856 $e =~ s/undefined subroutine &(?:main::|Language::INTERCAL::)?(\S+)/&$1?/i; | |
| 857 $e =~ s/called at \S*\/Language\/INTERCAL\//at /i | |
| 858 or $e =~ s/ at \S*\// at /i; | |
| 859 $e =~ s/Language::INTERCAL:://g; | |
| 860 $e =~ s/main:://g; | |
| 861 $e =~ s/via package/in/g; | |
| 862 $e =~ s/ line /:/g; | |
| 863 $e; | |
| 864 } | |
| 865 | |
| 866 sub _preload_callback { | |
| 867 my ($compiler, $file, $fn, $ct) = @_; | |
| 868 exists $object_types{uc($ct)} | |
| 869 or die "Invalid object type ($ct) for intercalc\n"; | |
| 870 my $rt = $object_types{uc($ct)}; | |
| 871 defined $rt or return; | |
| 872 exists $menu_defs{$rt} or return; | |
| 873 my ($name, $action, $multi) = @{$menu_defs{$rt}}; | |
| 874 if ($multi) { | |
| 875 $calculator{loaded}{$rt}{$file} = 1; | |
| 876 } else { | |
| 877 $calculator{loaded}{$rt} = $file; | |
| 878 } | |
| 879 } | |
| 880 | |
| 881 sub _being_robbed { | |
| 882 my ($obj, $type, $reg) = @_; | |
| 883 $type = $type =~ /steal/i ? 'stolen' : 'smuggled away'; | |
| 884 _status("Register $reg has been $type"); | |
| 885 1; | |
| 886 } | |
| 887 | |
| 888 sub _enable_keys { | |
| 889 my $enable_all = $ui->pending_events(); | |
| 890 $ui->forall('key', | |
| 891 sub { | |
| 892 my ($ui, $key, $name, $action) = @_; | |
| 893 $enable_all = 1 if ! $enable_all && $ui->pending_events(); | |
| 894 if ($action == \&_addkey) { | |
| 895 $name = ' ' if $name eq 'space'; | |
| 896 $enable_all || defined $calcptr->can_add($name) | |
| 897 ? $ui->enable($key) | |
| 898 : $ui->disable($key); | |
| 899 return 1; | |
| 900 } | |
| 901 if ($action == \&_delkey) { | |
| 902 $command ne '' | |
| 903 ? $ui->enable($key) | |
| 904 : $ui->disable($key); | |
| 905 return 1; | |
| 906 } | |
| 907 if ($action == \&_calculate) { | |
| 908 $enable_all || $calcptr->can_run() | |
| 909 ? $ui->enable($key) | |
| 910 : $ui->disable($key); | |
| 911 return 1; | |
| 912 } | |
| 913 return 1; | |
| 914 }); | |
| 915 $ui->enable_menu($enable_all || $command ne '', 'Edit', 'Backspace'); | |
| 916 $ui->enable_menu($enable_all || defined $current_file, 'File', 'Read Out'); | |
| 917 } | |
| 918 | |
| 919 sub _paste { | |
| 920 $give_up = 0; | |
| 921 $ui->do_paste; | |
| 922 } | |
| 923 | |
| 924 sub _popup { | |
| 925 my ($object, $list1, $list2, $title, $redo) = @_; | |
| 926 $give_up = 0; | |
| 927 if ($ui->has_window) { | |
| 928 _clear_status(); | |
| 929 my @inner = (); | |
| 930 for my $i (@$list2) { | |
| 931 if (ref $i) { | |
| 932 push @inner, | |
| 933 ['text', value => $i->[0] . ' ', align => 'l'], | |
| 934 ['text', value => $i->[1] . ' ', align => 'r'], | |
| 935 ['text', value => $i->[2], align => 'l']; | |
| 936 } else { | |
| 937 push @inner, | |
| 938 ['text', value => $i, align => 'l'], | |
| 939 'l', | |
| 940 'l'; | |
| 941 } | |
| 942 } | |
| 943 my $inner = [ 'table', columns => 3, alterable => 1, data => @inner]; | |
| 944 if (! $$object) { | |
| 945 my $destroy = sub { | |
| 946 $$object = undef; | |
| 947 $give_up = 0; | |
| 948 _clear_status(); | |
| 949 1; | |
| 950 }; | |
| 951 my $close = sub { | |
| 952 $ui->close($$object) if $$object; | |
| 953 $$object = undef; | |
| 954 $give_up = 0; | |
| 955 _clear_status(); | |
| 956 }; | |
| 957 $$object = $ui->window($title, $destroy, [ | |
| 958 'vstack', border => 2, data => | |
| 959 ['vstack', data => | |
| 960 (map { ['text', value => $_, align => 'c'] } @$list1), | |
| 961 (@$list1 && @$list2 ? (['text', value => '']) : ()), | |
| 962 $inner, | |
| 963 ['text', value => ''], | |
| 964 ['key', | |
| 965 name => 'OK', | |
| 966 key => ["\cJ", "\cM", qw(Enter Return Linefeed)], | |
| 967 action => $close | |
| 968 ], | |
| 969 ], | |
| 970 ]); | |
| 971 } elsif ($redo) { | |
| 972 $ui->alter_data($$object, $inner); | |
| 973 } | |
| 974 $ui->show($$object); | |
| 975 } else { | |
| 976 my $stdread = $ui->stdread; | |
| 977 $stdread->read_text("$_\n") for @$list1; | |
| 978 $stdread->read_text("\n") if @$list1 && @$list2; | |
| 979 $stdread->read_text("$_\n") for @$list2; | |
| 980 } | |
| 981 } | |
| 982 | |
| 983 sub _stop_calculator { | |
| 984 $calculator{running} = $running = 0; | |
| 985 $ui->stop if $ui->has_window; | |
| 986 } | |
| 987 | |
| 988 sub _restart_calculator { | |
| 989 my ($full_restart) = @_; | |
| 990 $calculator{running} = 0; | |
| 991 $calculator{full_restart} = 1 if $full_restart; | |
| 992 $running = 1; | |
| 993 $ui->stop if $ui->has_window; | |
| 994 } | |
| 995 | |
| 996 sub _about { | |
| 997 _popup(\$about_object, \@about_text, \@copyright, 'About', 0); | |
| 998 ''; | |
| 999 } | |
| 1000 | |
| 1001 sub _help { | |
| 1002 _popup(\$help_object, \@for, \@help_text, 'Help', 0); | |
| 1003 ''; | |
| 1004 } | |
| 1005 | |
| 1006 sub _reserved { | |
| 1007 $give_up = 0; | |
| 1008 $reserved++; | |
| 1009 $reserved == 1 and return "That key is reserved. Don't press it again"; | |
| 1010 $reserved == 2 and return "I really mean it. Don't press that key"; | |
| 1011 $reserved > 2 and do { | |
| 1012 _status("Well, you've asked for it. Didn't I tell you?"); | |
| 1013 $ui->update(); | |
| 1014 _stop_calculator(); | |
| 1015 }; | |
| 1016 ''; | |
| 1017 } | |
| 1018 | |
| 1019 sub _undocumented { | |
| 1020 my @interface = make_interface(0); | |
| 1021 my $interface = _convert(\@interface); | |
| 1022 "undocumented data: " . $interface . "\n"; | |
| 1023 } | |
| 1024 | |
| 1025 sub _convert { | |
| 1026 my ($item) = @_; | |
| 1027 defined $item or return "u"; | |
| 1028 if (ref $item) { | |
| 1029 UNIVERSAL::isa($item, 'ARRAY') | |
| 1030 and return "a(" . join(' ', map { _convert($_) } @$item) . ")"; | |
| 1031 UNIVERSAL::isa($item, 'CODE') | |
| 1032 and return "c"; | |
| 1033 die "Type not understood: $item\n"; | |
| 1034 } else { | |
| 1035 $item =~ s/([%\(\)\000- \177-\377])/sprintf("%%%03d", ord($1))/ge; | |
| 1036 return "d$item"; | |
| 1037 } | |
| 1038 } | |
| 1039 | |
| 1040 sub _version { | |
| 1041 "INTERCALC (CLC-INTERCAL $VERSION)\n"; | |
| 1042 } | |
| 1043 | |
| 1044 sub _give_up { | |
| 1045 if ($give_up) { | |
| 1046 _stop_calculator(); | |
| 1047 return ''; | |
| 1048 } | |
| 1049 $give_up = 1; | |
| 1050 "Do that again to really GIVE UP\n"; | |
| 1051 } | |
| 1052 | |
| 1053 sub _after_action { | |
| 1054 my ($ui, $res, $menu_name, $menu_entry) = @_; | |
| 1055 $res and _status(_shorten($res)); | |
| 1056 } | |
| 1057 | |
| 1058 sub _sickrc { | |
| 1059 my ($ui, $menu_name, $menu_entry) = @_; | |
| 1060 $give_up = 0; | |
| 1061 my %newoptions = ( | |
| 1062 LANGUAGE => [$language, { '' => [ $base, @options] } ], | |
| 1063 MODE => [$mode], | |
| 1064 ); | |
| 1065 $rcfile->program_setoptions('INTERCALC', \%newoptions); | |
| 1066 $rcfile->save(); | |
| 1067 return ''; | |
| 1068 } | |
| 1069 | |
| 1070 sub _read_or_readas { | |
| 1071 my ($ui, $menu_name, $menu_entry) = @_; | |
| 1072 $give_up = 0; | |
| 1073 $menu_entry eq '' and return _read($ui, $menu_name, $menu_entry); | |
| 1074 return save_state($menu_entry, 0); | |
| 1075 } | |
| 1076 | |
| 1077 sub _read { | |
| 1078 my ($ui, $menu_name, $menu_entry) = @_; | |
| 1079 $give_up = 0; | |
| 1080 defined $current_file | |
| 1081 or return "Cannot read out without a file name\n"; | |
| 1082 return save_state($current_file, 1); | |
| 1083 } | |
| 1084 | |
| 1085 sub _read_as { | |
| 1086 my ($ui, $menu_name, $menu_entry) = @_; | |
| 1087 $give_up = 0; | |
| 1088 my $new = $current_file || ''; | |
| 1089 my $file = $ui->file_dialog("Read AS", $new, "Read it", "Give up"); | |
| 1090 defined $file or return ''; | |
| 1091 return save_state($file, 0); | |
| 1092 } | |
| 1093 | |
| 1094 sub _write { | |
| 1095 my ($ui, $menu_name, $menu_entry) = @_; | |
| 1096 $give_up = 0; | |
| 1097 my $file = $ui->file_dialog("Write In", undef, "Write it", "Give up"); | |
| 1098 defined $file or return ''; | |
| 1099 return _write_file($ui, $menu_name, $file); | |
| 1100 } | |
| 1101 | |
| 1102 sub _write_file { | |
| 1103 my ($ui, $menu_name, $menu_entry) = @_; | |
| 1104 $give_up = 0; | |
| 1105 my ($ret, $reload) = load_state($menu_entry); | |
| 1106 _restart_calculator(1) if $reload; | |
| 1107 $ret; | |
| 1108 } | |
| 1109 | |
| 1110 sub _history { | |
| 1111 my ($ui, $menu_name, $menu_entry) = @_; | |
| 1112 _history_trace($menu_entry, 0, 0); | |
| 1113 } | |
| 1114 | |
| 1115 sub _history_w { | |
| 1116 my ($ui, $menu_name, $menu_entry) = @_; | |
| 1117 _history_trace('', 0, 0); | |
| 1118 } | |
| 1119 | |
| 1120 sub _trace { | |
| 1121 my ($ui, $menu_name, $menu_entry) = @_; | |
| 1122 _history_trace($menu_entry, 1, 0); | |
| 1123 } | |
| 1124 | |
| 1125 sub _trace_w { | |
| 1126 my ($ui, $menu_name, $menu_entry) = @_; | |
| 1127 _history_trace('', 1, 0); | |
| 1128 } | |
| 1129 | |
| 1130 sub _history_trace { | |
| 1131 my ($size, $with_trace, $redo) = @_; | |
| 1132 $give_up = 0; | |
| 1133 my $object; | |
| 1134 if ($ui->has_window) { | |
| 1135 $object = $with_trace ? \$trace_object : \$history_object; | |
| 1136 return if $redo && ! $$object; | |
| 1137 return if ! $redo && $$object; | |
| 1138 } | |
| 1139 if ($size) { | |
| 1140 $size =~ /^(\d+)/ or return "Invalid number $size\n"; | |
| 1141 } | |
| 1142 my @lines = (); | |
| 1143 my $fmt = "%s%$calculator{display_size}s %s\n"; | |
| 1144 my $read_lines = $ui->has_window | |
| 1145 ? sub { push @lines, @_ } | |
| 1146 : sub { $ui->stdread->read_text($_ . "\n") for @_ }; | |
| 1147 my $read_mult = $ui->has_window | |
| 1148 ? sub { push @lines, [@_] } | |
| 1149 : sub { $ui->stdread->read_text(sprintf $fmt, @_) }; | |
| 1150 $read_lines->("Command history" . | |
| 1151 ($with_trace ? " and trace information" : '')); | |
| 1152 $read_lines->("(Note that you need to enable the \"trace\" " . | |
| 1153 "option to see trace information)") | |
| 1154 if $with_trace && ! exists $calculator{loaded}{OPTION}{trace}; | |
| 1155 my @title = @lines; | |
| 1156 @lines = (); | |
| 1157 my $calculation = ''; | |
| 1158 my @trace = (); | |
| 1159 my $OK = $with_trace ? '' : 'OK'; | |
| 1160 for my $hl (@history, ['c']) { | |
| 1161 my ($type, $line) = @$hl; | |
| 1162 if ($type eq 'c') { | |
| 1163 if ($size ne '') { | |
| 1164 $size--; | |
| 1165 last if $size < 0; | |
| 1166 } | |
| 1167 if ($calculation ne '' || $with_trace) { | |
| 1168 $read_lines->(@trace); | |
| 1169 @trace = (); | |
| 1170 next if $with_trace && ! defined $line; | |
| 1171 $calculation = $line if $with_trace; | |
| 1172 my $memory = ''; | |
| 1173 $memory = ' ' x (1 + $calculator{digits}) | |
| 1174 if $calculator{has_memory}; | |
| 1175 $read_mult->($memory, $OK, $calculation); | |
| 1176 } | |
| 1177 $calculation = $with_trace ? '' : $line; | |
| 1178 } elsif ($type eq 'r') { | |
| 1179 my $memory = ''; | |
| 1180 $memory = $1 if $calculator{has_memory} && $line =~ s/^(\S+)\s//; | |
| 1181 $read_mult->($memory, $line, $calculation); | |
| 1182 $calculation = ''; | |
| 1183 } elsif ($type eq 't' && $with_trace) { | |
| 1184 unshift @trace, $line; | |
| 1185 } | |
| 1186 } | |
| 1187 if ($ui->has_window) { | |
| 1188 _popup($object, \@title, \@lines, | |
| 1189 $with_trace ? 'Trace' : 'History', $redo); | |
| 1190 } | |
| 1191 ''; | |
| 1192 } | |
| 1193 | |
| 1194 #sub _redo_history { | |
| 1195 # my ($object, $with_trace) = @_; | |
| 1196 # $ui->start_alter($object); | |
| 1197 # my $calculation = ''; | |
| 1198 # my @trace = (); | |
| 1199 # my $OK = $with_trace ? '' : 'OK'; | |
| 1200 # for my $hl (@history, ['c']) { | |
| 1201 # my ($type, $line) = @$hl; | |
| 1202 # if ($type eq 'c') { | |
| 1203 # if ($calculation ne '' || $with_trace) { | |
| 1204 # $ui->augment($object, 0, @trace) if @trace; | |
| 1205 # @trace = (); | |
| 1206 # next if $with_trace && ! defined $line; | |
| 1207 # $calculation = $line if $with_trace; | |
| 1208 # my $memory = ''; | |
| 1209 # $memory = ' ' x (1 + $calculator{digits}) | |
| 1210 # if $calculator{has_memory}; | |
| 1211 # $ui->augment($object, 1, $memory, $OK, $calculation); | |
| 1212 # } | |
| 1213 # $calculation = $with_trace ? '' : $line; | |
| 1214 # } elsif ($type eq 'r') { | |
| 1215 # my $memory = ''; | |
| 1216 # $memory = $1 if $calculator{has_memory} && $line =~ s/^(\S+)\s//; | |
| 1217 # $ui->augment($object, 1, $memory, $line, $calculation); | |
| 1218 # $calculation = ''; | |
| 1219 # } elsif ($type eq 't' && $with_trace) { | |
| 1220 # unshift @trace, $line; | |
| 1221 # } | |
| 1222 # } | |
| 1223 # $ui->end_alter($object); | |
| 1224 #} | |
| 1225 | |
| 1226 sub _change_mode { | |
| 1227 my ($ui, $menu_name, $menu_entry) = @_; | |
| 1228 $give_up = 0; | |
| 1229 if ($menu_entry eq '') { | |
| 1230 die "Internal error: no menu entry\n" if $ui->has_window; | |
| 1231 my @mode = map { lc($mode) eq lc($_) ? "*$_" : $_ } qw(OIC Expr Full); | |
| 1232 return "Available modes: " . join(', ', @mode) . "\n"; | |
| 1233 } | |
| 1234 return '' if $mode eq lc($menu_entry); | |
| 1235 return "Invalid mode: $menu_entry\n" | |
| 1236 if $menu_entry !~ /^(?:oic\d*|expr|full)$/i; | |
| 1237 if ($ui->has_window) { | |
| 1238 $ui->forall('menu', $menu_name, sub { | |
| 1239 my ($_ui, $name, $entry, $menu, $item) = @_; | |
| 1240 $_ui->tick_menu($menu_entry eq $entry, $name, $entry); | |
| 1241 1; | |
| 1242 }); | |
| 1243 } | |
| 1244 $mode = lc($menu_entry); | |
| 1245 _restart_calculator(0); | |
| 1246 "Mode changed to $mode\n"; | |
| 1247 } | |
| 1248 | |
| 1249 sub _change_base { | |
| 1250 my ($ui, $menu_name, $menu_entry) = @_; | |
| 1251 $give_up = 0; | |
| 1252 if ($ui->has_window) { | |
| 1253 $ui->forall('menu', $menu_name, sub { | |
| 1254 my ($_ui, $name, $entry, $menu, $item) = @_; | |
| 1255 $_ui->tick_menu($menu_entry eq $entry, $name, $entry); | |
| 1256 1; | |
| 1257 }); | |
| 1258 } | |
| 1259 if ($menu_entry ne $calculator{loaded}{BASE}) { | |
| 1260 $calculator{loaded}{BASE} = $menu_entry; | |
| 1261 $calculator{object}->setreg('%BA', $menu_entry); | |
| 1262 } | |
| 1263 "Base changed to $menu_entry\n"; | |
| 1264 } | |
| 1265 | |
| 1266 sub _change_language { | |
| 1267 my ($ui, $menu_name, $menu_entry) = @_; | |
| 1268 $give_up = 0; | |
| 1269 my ($newlang, @opts, $change_opts); | |
| 1270 if ($menu_entry =~ s/^(\w+)\s*\+\s*//) { | |
| 1271 $newlang = $1; | |
| 1272 if ($menu_entry =~ /\S/) { | |
| 1273 @opts = split(/\s+/, $menu_entry); | |
| 1274 } else { | |
| 1275 @opts = (); | |
| 1276 } | |
| 1277 my $loaded = $calculator{need_reload} || $calculator{loaded}; | |
| 1278 for my $o (@opts) { | |
| 1279 next if exists $loaded->{OPTION}{$o}; | |
| 1280 $change_opts = 1; | |
| 1281 last; | |
| 1282 } | |
| 1283 if (! $change_opts) { | |
| 1284 my %o = map { ($_ => 1) } @opts; | |
| 1285 for my $o (keys %{$loaded->{OPTION}}) { | |
| 1286 next if exists $o{$o}; | |
| 1287 $change_opts = 1; | |
| 1288 last; | |
| 1289 } | |
| 1290 } | |
| 1291 } else { | |
| 1292 $newlang = $menu_entry; | |
| 1293 @opts = (); | |
| 1294 $change_opts = 0; | |
| 1295 } | |
| 1296 if ($ui->has_window) { | |
| 1297 $ui->forall('menu', $menu_name, sub { | |
| 1298 my ($_ui, $name, $entry, $menu, $item) = @_; | |
| 1299 $_ui->tick_menu($newlang eq $entry, $name, $entry); | |
| 1300 1; | |
| 1301 }); | |
| 1302 } | |
| 1303 my $opts = ''; | |
| 1304 if ($change_opts) { | |
| 1305 $calculator{full_restart} = 1; | |
| 1306 _need_reload('LANGUAGE', $newlang, 'OPTION', @opts); | |
| 1307 $opts = ' (' . join(', ', @opts) . ')'; | |
| 1308 } elsif ($newlang ne $calculator{loaded}{LANGUAGE}) { | |
| 1309 $calculator{full_restart} = 1; | |
| 1310 _need_reload('LANGUAGE', $newlang); | |
| 1311 } | |
| 1312 "Language changed to $newlang$opts\n"; | |
| 1313 } | |
| 1314 | |
| 1315 sub _toggle_option { | |
| 1316 my ($ui, $menu_name, $menu_entry) = @_; | |
| 1317 $give_up = 0; | |
| 1318 $calculator{full_restart} = 1; | |
| 1319 _need_reload('OPTION', $menu_entry); | |
| 1320 if ($ui->has_window) { | |
| 1321 my $t = exists $calculator{need_reload}{'OPTION'}{$menu_entry}; | |
| 1322 $ui->tick_menu($t, $menu_name, $menu_entry); | |
| 1323 } | |
| 1324 "Option $menu_entry has been " . | |
| 1325 (exists $calculator{need_reload}{OPTION}{$menu_entry} | |
| 1326 ? "added" | |
| 1327 : "removed") . | |
| 1328 "\n"; | |
| 1329 } | |
| 1330 | |
| 1331 sub _need_reload { | |
| 1332 my ($type, $name, $othertype, @othernames) = @_; | |
| 1333 if (! $calculator{need_reload}) { | |
| 1334 my %r = (); | |
| 1335 for my $t (keys %{$calculator{loaded}}) { | |
| 1336 my $v = $calculator{loaded}{$t}; | |
| 1337 if (ref $v) { | |
| 1338 my %h = (); | |
| 1339 $h{$_} = 1 for keys %$v; | |
| 1340 $r{$t} = \%h; | |
| 1341 } else { | |
| 1342 $r{$t} = $v; | |
| 1343 } | |
| 1344 } | |
| 1345 $calculator{need_reload} = \%r; | |
| 1346 } | |
| 1347 if (ref $calculator{need_reload}{$type}) { | |
| 1348 if (exists $calculator{need_reload}{$type}{$name}) { | |
| 1349 delete $calculator{need_reload}{$type}{$name}; | |
| 1350 } else { | |
| 1351 $calculator{need_reload}{$type}{$name} = 1; | |
| 1352 } | |
| 1353 } else { | |
| 1354 $calculator{need_reload}{$type} = $name; | |
| 1355 } | |
| 1356 if (defined $othertype) { | |
| 1357 $calculator{need_reload}{$othertype} = { | |
| 1358 map { ($_ => 1) } @othernames, | |
| 1359 }; | |
| 1360 } | |
| 1361 _restart_calculator(0); | |
| 1362 } | |
| 1363 | |
| 1364 sub _clear { | |
| 1365 $give_up = 0; | |
| 1366 _clear_status(); | |
| 1367 $command = ''; | |
| 1368 $ui->set_text('command', ''); | |
| 1369 _enable_keys(); | |
| 1370 '' | |
| 1371 } | |
| 1372 | |
| 1373 sub _addkey { | |
| 1374 my ($key) = @_; | |
| 1375 $give_up = 0; | |
| 1376 $key = ' ' if $key eq 'space'; | |
| 1377 my $ok = $calcptr->can_add($key); | |
| 1378 if (defined $ok) { | |
| 1379 if (ref $ok) { | |
| 1380 $command .= $$ok; | |
| 1381 _calculate(); | |
| 1382 return; | |
| 1383 } else { | |
| 1384 $command .= $ok; | |
| 1385 _enable_keys(); | |
| 1386 } | |
| 1387 } | |
| 1388 _clear_status(); | |
| 1389 '' | |
| 1390 } | |
| 1391 | |
| 1392 sub _calculate { | |
| 1393 $give_up = 0; | |
| 1394 my $c = $command; | |
| 1395 my $i = $ui->has_window; | |
| 1396 if ($c eq '') { | |
| 1397 _clear_status() if $i; | |
| 1398 } else { | |
| 1399 my ($calculation, $memory, $scroll, @result) = $calcptr->run($c); | |
| 1400 $command = ''; | |
| 1401 $ui->set_text('command', $calculation) if $i; | |
| 1402 my $orig_calc = $calculation; | |
| 1403 my $saveit = ! $scroll; | |
| 1404 for my $result (@result) { | |
| 1405 $result =~ s/\s+$//; | |
| 1406 $result =~ s/\n/ /g; | |
| 1407 my $histline = $calculator{has_memory} | |
| 1408 ? join(' ', $memory, $result) | |
| 1409 : $result; | |
| 1410 if ($saveit) { | |
| 1411 unshift @history, ['r', $histline]; | |
| 1412 $saveit = 0; | |
| 1413 } | |
| 1414 if (exists $calculator{skip_scroll}) { | |
| 1415 delete $calculator{skip_scroll}; | |
| 1416 } else { | |
| 1417 if ($i) { | |
| 1418 for (my $h = $history; $h >= 1; $h--) { | |
| 1419 my $ph = $h == 1 ? '' : $h - 1; | |
| 1420 $ui->set_text("display$h", $ui->get_text("display$ph")); | |
| 1421 $ui->set_text("memory$h", $ui->get_text("memory$ph")) | |
| 1422 if $calculator{has_memory}; | |
| 1423 } | |
| 1424 } | |
| 1425 } | |
| 1426 if ($i) { | |
| 1427 $ui->set_text('display', $result); | |
| 1428 $ui->set_text('memory', $memory) if $calculator{has_memory}; | |
| 1429 } else { | |
| 1430 my $l = sprintf "%s%$calculator{display_size}s %s\n", | |
| 1431 $calculator{has_memory} ? $memory : '', | |
| 1432 $result, $calculation; | |
| 1433 $ui->stdread->read_text($l); | |
| 1434 } | |
| 1435 $memory = $calculation = ''; | |
| 1436 } | |
| 1437 unshift @history, ['c', $orig_calc]; | |
| 1438 $calculator{skip_scroll} = 1 if $scroll; | |
| 1439 } | |
| 1440 if ($i) { | |
| 1441 $history_object and _history_trace('', 0, 1); | |
| 1442 $trace_object and _history_trace('', 1, 1); | |
| 1443 _enable_keys(); | |
| 1444 } | |
| 1445 '' | |
| 1446 } | |
| 1447 | |
| 1448 sub _delkey { | |
| 1449 $give_up = 0; | |
| 1450 _clear_status(); | |
| 1451 $command =~ s/.$//; | |
| 1452 $ui->set_text('command', $command); | |
| 1453 _enable_keys(); | |
| 1454 '' | |
| 1455 } | |
| 1456 | |
| 1457 sub _clear_status { | |
| 1458 $ui->set_text('command', $command); | |
| 1459 if ($calculator{skip_scroll}) { | |
| 1460 $calculator{skip_scroll} = 0; | |
| 1461 $ui->set_text("display", ''); | |
| 1462 $ui->set_text("memory", '') if $calculator{has_memory}; | |
| 1463 } | |
| 1464 } | |
| 1465 | |
| 1466 sub _status { | |
| 1467 my ($msg) = @_; | |
| 1468 if ($ui->has_window) { | |
| 1469 $msg =~ s/\n$//; | |
| 1470 $ui->set_text('command', $msg); | |
| 1471 $ui->update(); | |
| 1472 } else { | |
| 1473 $msg .= "\n" unless $msg =~ /\n$/; | |
| 1474 $ui->stdread->read_text($msg); | |
| 1475 } | |
| 1476 ''; | |
| 1477 } | |
| 1478 | |
| 1479 sub _complete { | |
| 1480 my ($text) = @_; | |
| 1481 my $T = $text; | |
| 1482 if ($T =~ s/^\s*`\s*//) { | |
| 1483 if ($T eq '') { | |
| 1484 return grep { $_ ne "\0" } keys %escape_defs; | |
| 1485 } | |
| 1486 my $c = substr($T, 0, 1, ''); | |
| 1487 $T =~ s/^\s+//; | |
| 1488 exists $escape_defs{$c} or return (); | |
| 1489 my ($code, $list, $term, $names) = @{$escape_defs{$c}}; | |
| 1490 defined $list or return (); | |
| 1491 if ($list) { | |
| 1492 if (defined $term) { | |
| 1493 my $i = index($T, $term); | |
| 1494 if ($i >= 0) { | |
| 1495 $T = substr($T, $i + 1); | |
| 1496 $T =~ s/^.*\s+//; | |
| 1497 $list = 'OPTION'; | |
| 1498 $term = ' '; | |
| 1499 } | |
| 1500 } | |
| 1501 my @l = map { | |
| 1502 substr($_, length $T); | |
| 1503 } grep { | |
| 1504 substr($_, 0, length $T) eq $T; | |
| 1505 } @{$objects_found->{$list}}; | |
| 1506 if (defined $term && @l == 1 && $l[0] eq '') { | |
| 1507 push @l, $term; | |
| 1508 } | |
| 1509 return @l; | |
| 1510 } elsif ($c eq 'h' || $c eq 't') { | |
| 1511 return (0..9); | |
| 1512 } elsif ($c eq 'm') { | |
| 1513 return (0..9) if $T =~ /^oic/i; | |
| 1514 my @l = grep { | |
| 1515 lc(substr($_, 0, length $T)) eq lc($T); | |
| 1516 } @{$objects_found->{MODE}}; | |
| 1517 return map { substr($_, length $T) } @l; | |
| 1518 } | |
| 1519 } else { | |
| 1520 return $calcptr->complete($text); | |
| 1521 } | |
| 1522 } | |
| 1523 | |
| 1524 sub usage { | |
| 1525 (my $p = $0) =~ s#^.*/##; | |
| 1526 die "Usage: $p [-alphabet] [files]\n"; | |
| 1527 } | |
| 1528 | |
| 1529 package INC; | |
| 1530 | |
| 1531 sub can_add { | |
| 1532 my ($inc, $key) = @_; | |
| 1533 my ($ok, $cpl, $kcpl) = _check($inc, $command); | |
| 1534 $kcpl && exists $kcpl->{$key} ? $key : undef; | |
| 1535 } | |
| 1536 | |
| 1537 sub _check { | |
| 1538 my ($inc, $line) = @_; | |
| 1539 return (0, {}) if $@; | |
| 1540 return @{$inc->{cache}{$line}} if exists $inc->{cache}{$line}; | |
| 1541 my $run = 0; | |
| 1542 my $cpl = {}; | |
| 1543 my $kcpl = {}; | |
| 1544 eval { | |
| 1545 my ($l, $c) = $inc->{parser}->compile($inc->{s_line}, $line, 0, | |
| 1546 $inc->{s_space}, 0); | |
| 1547 $run = grep { $_->[1] == length($line) } @$l; | |
| 1548 my %cpl = (); | |
| 1549 my %kcpl = (); | |
| 1550 for my $cpl (@$c) { | |
| 1551 $cpl{$cpl} = 1; | |
| 1552 $kcpl{substr($cpl, 0, 1)} = 1; | |
| 1553 } | |
| 1554 $cpl = \%cpl; | |
| 1555 $kcpl = \%kcpl; | |
| 1556 }; | |
| 1557 $inc->{cache}{$line} = [$run, $cpl, $kcpl]; | |
| 1558 return @{$inc->{cache}{$line}}; | |
| 1559 } | |
| 1560 | |
| 1561 sub can_run { | |
| 1562 my ($inc) = @_; | |
| 1563 my ($ok, $cpl, $kcpl) = _check($inc, $command); | |
| 1564 $ok; | |
| 1565 } | |
| 1566 | |
| 1567 sub complete { | |
| 1568 my ($inc, $text) = @_; | |
| 1569 my ($ok, $cpl, $kcpl) = _check($inc, $text); | |
| 1570 return $cpl ? (keys %$cpl) : (); | |
| 1571 } | |
| 1572 | |
| 1573 sub run { | |
| 1574 my ($inc, $oline) = @_; | |
| 1575 my @result; | |
| 1576 eval { | |
| 1577 my $line = $oline; | |
| 1578 my ($l) = $inc->{parser}->compile($inc->{s_line}, $line, 0, | |
| 1579 $inc->{s_space}, 0); | |
| 1580 die "Syntax error\n" unless @$l; | |
| 1581 my @l = map { $_->[3] } grep { $_->[1] == length $line } @$l; | |
| 1582 die "Syntax error\n" unless @l; | |
| 1583 my $pos = length $line; | |
| 1584 my ($g) = $inc->{parser}->compile($inc->{s_statement}, | |
| 1585 "$line\nDO GIVE UP", $pos, | |
| 1586 $inc->{s_space}, 0); | |
| 1587 my @g = map { $_->[3] } @$g; | |
| 1588 push @l, @g; | |
| 1589 $inc->{object}->object->code(\@l); | |
| 1590 $inc->{object}->object->source($line); | |
| 1591 ${$inc->{read_data}} = ''; | |
| 1592 $inc->{read_fh}->reset; | |
| 1593 $inc->{object}->start(2)->run()->stop(); | |
| 1594 $inc->{cache} = {} if $inc->{invalidate}; | |
| 1595 @result = grep { /./ } split(/\n+/, ${$inc->{read_data}}); | |
| 1596 }; | |
| 1597 push @result, $@ if $@; | |
| 1598 for (@result) { | |
| 1599 $_ = main::_shorten($_) if /\*\d{3}/ && $ui->has_window; | |
| 1600 } | |
| 1601 my $scroll = 0; | |
| 1602 unless (@result) { | |
| 1603 push @result, 'OK'; | |
| 1604 $scroll = 1; | |
| 1605 } | |
| 1606 ($oline, '', $scroll, @result); | |
| 1607 } | |
| 1608 | |
| 1609 package OIC; | |
| 1610 | |
| 1611 sub run { | |
| 1612 my ($oic, $line) = @_; | |
| 1613 my $calculation = ''; | |
| 1614 my $memory = ' ' x (1 + $oic->{digits}); | |
| 1615 my @result = (); | |
| 1616 eval { | |
| 1617 $line =~ s/\s+//g; | |
| 1618 $calculation = '('; | |
| 1619 my $a = _extract_oic($oic, \$line, \$calculation); | |
| 1620 die "Missing number\n" if $a eq ''; | |
| 1621 $calculation .= ' - '; | |
| 1622 my $b = _extract_oic($oic, \$line, \$calculation); | |
| 1623 die "Missing number\n" if $b eq ''; | |
| 1624 $calculation .= ') / '; | |
| 1625 my $c = _extract_oic($oic, \$line, \$calculation); | |
| 1626 die "Missing number\n" if $c eq ''; | |
| 1627 $line =~ s/$oic->{regex}// | |
| 1628 or die "Invalid result: $line\n"; | |
| 1629 $1 >= $oic->{nmems} | |
| 1630 and die "Invalid memory $1\n"; | |
| 1631 my $m = $1; | |
| 1632 $memory = sprintf $oic->{format}, $m; | |
| 1633 my $result = ($a - $b) / $c; | |
| 1634 $oic->{memory}[$m] = $result; | |
| 1635 push @result, $result; | |
| 1636 $line eq '' or die "Extra data after line: $line\n"; | |
| 1637 }; | |
| 1638 push @result, $@ if $@; | |
| 1639 ($calculation, $memory, 0, @result); | |
| 1640 } | |
| 1641 | |
| 1642 sub _extract_oic { | |
| 1643 my ($oic, $line, $calculation) = @_; | |
| 1644 if ($$line =~ s/$oic->{regex}//) { | |
| 1645 $1 >= $oic->{nmems} | |
| 1646 and die "Invalid memory $1\n"; | |
| 1647 $$calculation .= sprintf $oic->{format}, $1; | |
| 1648 return $oic->{memory}[$1]; | |
| 1649 } | |
| 1650 if ($$line =~ s/^(-?\d+\.\d*|-?\d*\.\d+|-?\d+)//) { | |
| 1651 $$calculation .= $1; | |
| 1652 return $1; | |
| 1653 } | |
| 1654 die "Invalid syntax: $line\n"; | |
| 1655 } | |
| 1656 | |
| 1657 sub _check { | |
| 1658 my ($oic, $c, $key) = @_; | |
| 1659 my $l = $c . $key; | |
| 1660 for (1..3) { | |
| 1661 my $r = ''; | |
| 1662 last if $l =~ s/^(?:-\.?|\.|m)$//i; | |
| 1663 eval { _extract_oic($oic, \$l, \$r) }; | |
| 1664 return undef if $@; | |
| 1665 return $key if $l eq ''; | |
| 1666 } | |
| 1667 if ($l ne '') { | |
| 1668 $l =~ s/^m//i or return undef; | |
| 1669 $l =~ /^\d*$/ or return undef; | |
| 1670 return \$key if length($l) == $oic->{digits}; | |
| 1671 } | |
| 1672 return $key; | |
| 1673 } | |
| 1674 | |
| 1675 sub can_add { | |
| 1676 my ($oic, $key) = @_; | |
| 1677 _check($oic, $command, $key); | |
| 1678 } | |
| 1679 | |
| 1680 sub complete { | |
| 1681 my ($oic, $text) = @_; | |
| 1682 grep { defined _check($oic, $text, $_) } (0..9, '-', '.', 'm'); | |
| 1683 } | |
| 1684 | |
| 1685 sub can_run { | |
| 1686 my ($oic) = @_; | |
| 1687 my $ok = _check($oic, $command, ''); | |
| 1688 defined $ok && ref $ok; | |
| 1689 } | |
| 1690 | |
| 1691 package WOBJ; | |
| 1692 | |
| 1693 sub write { | |
| 1694 my ($wobj, $size) = @_; | |
| 1695 while (1) { | |
| 1696 return '' if ! defined $$wobj; | |
| 1697 return substr($$wobj, 0, $size, '') if length $$wobj >= $size; | |
| 1698 my $l = $ui->getline("DATA: "); | |
| 1699 if (defined $l && $l ne '') { | |
| 1700 $$wobj .= $l; | |
| 1701 } else { | |
| 1702 $l = $$wobj; | |
| 1703 $$wobj = ''; | |
| 1704 return $l; | |
| 1705 } | |
| 1706 } | |
| 1707 } | |
| 1708 | |
| 1709 package TOBJ; | |
| 1710 | |
| 1711 sub read { | |
| 1712 my ($tobj, $line) = @_; | |
| 1713 $tobj->[1] or return; | |
| 1714 $tobj->[0] .= $line; | |
| 1715 my $sr = $ui->has_window ? undef : $ui->stdread; | |
| 1716 while ($tobj->[0] =~ s/^(.*?)\n//) { | |
| 1717 unshift @history, ['t', $1] if $1 ne ''; | |
| 1718 if ($sr) { | |
| 1719 $sr->read_text($1 . "\n"); | |
| 1720 } elsif ($trace_object) { | |
| 1721 main::_history_trace('', 1, 1); | |
| 1722 } | |
| 1723 } | |
| 1724 } | |
| 1725 | |
| 1726 sub enable { | |
| 1727 my ($tobj, $yes) = @_; | |
| 1728 $tobj->[1] = $yes; | |
| 1729 } | |
| 1730 | |
| 1731 __END__ | |
| 1732 | |
| 1733 =pod | |
| 1734 | |
| 1735 =head1 NAME | |
| 1736 | |
| 1737 intercalc - CLC-INTERCAL desk calculator | |
| 1738 | |
| 1739 =head1 SYNOPSIS | |
| 1740 | |
| 1741 B<intercalc> [options] | |
| 1742 | |
| 1743 =head1 DESCRIPTION | |
| 1744 | |
| 1745 B<intercalc> is a simple desk calculator, allowing the user to | |
| 1746 enter INTERCAL statements (to see what they do) and expressions | |
| 1747 (to see what value they produce); it uses an interpreter object | |
| 1748 from CLC-INTERCAL to provide immediate feedback. | |
| 1749 | |
| 1750 The desk calculator accepts several options, some of which are documented here. | |
| 1751 | |
| 1752 =head2 User Interface Options | |
| 1753 | |
| 1754 =over 4 | |
| 1755 | |
| 1756 =item B<-X> / B<--graphic> | |
| 1757 | |
| 1758 Enters X-based graphical user interface. Requires Perl-GTK. This is the | |
| 1759 default if Perl-GTK is installed, the environment variable I<$DISPLAY> is | |
| 1760 set and the opening of the X display succeeds. | |
| 1761 | |
| 1762 =item B<-c> / B<--curses> | |
| 1763 | |
| 1764 Enters full screen, curses-based interface. This is the default if the | |
| 1765 X based interface cannot be started, the environment variable I<$TERM> | |
| 1766 is set and the terminal name is known. | |
| 1767 | |
| 1768 =item B<--line> | |
| 1769 | |
| 1770 Enters the line-mode user interface. This is the default if the X based | |
| 1771 and the curses based interfaces do not work. | |
| 1772 | |
| 1773 In this mode, the program executes each line from standard input according | |
| 1774 to the current mode and language, and prints results to standard output. | |
| 1775 A line starting with a backspark is interpreted as a command to the | |
| 1776 calculator. Use backspark-g to GIVE UP (you'll need to do it twice), or | |
| 1777 backspark-h to display the ehm, help page. Things which are available | |
| 1778 via menu entries on the Curses and X interfaces are also available via | |
| 1779 the backspark. For now, you can refer to the source code for a list. | |
| 1780 | |
| 1781 Command-line editing and command history is provided by the readline | |
| 1782 library. Command completion works if the underlying compiler supports it | |
| 1783 (the compilers provided with the distributions do). | |
| 1784 | |
| 1785 =item B<--batch> | |
| 1786 | |
| 1787 Avoids entering interactive mode. This is the default if the standard | |
| 1788 input and output are not connected to a terminal and the X based interface | |
| 1789 cannot be started. This mode is very similar to the line mode except that | |
| 1790 command-line editing and command history are not implemented. Backspark | |
| 1791 escapes work just the same. | |
| 1792 | |
| 1793 =item B<-i>I<type> / B<--interface>=I<type> | |
| 1794 | |
| 1795 Selects the user interface I<type>. Currently, only I<X>, I<Curses>, | |
| 1796 I<Line> and I<None> are defined, but more can be installed as compiler | |
| 1797 plug-ins. If the interface selected is I<None>, B<intercalc> will work in | |
| 1798 batch mode. In addition, an empty string will reinstate the default | |
| 1799 behaviour. | |
| 1800 | |
| 1801 =back | |
| 1802 | |
| 1803 =head2 Source language and compilation options | |
| 1804 | |
| 1805 =over 4 | |
| 1806 | |
| 1807 =item B<--bug>=I<number> | |
| 1808 | |
| 1809 Selects a different probability for the compiler bug. The compiler bug is | |
| 1810 implemented by initialising the compiler's state with the required probability: | |
| 1811 when a statement is compiled (usually at runtime), a "BUG" instruction is | |
| 1812 emitted with the required probability. The default is 1%. | |
| 1813 | |
| 1814 =item B<--ubug>=I<number> | |
| 1815 | |
| 1816 Selects a probability for the unexplainable compiler bug. This is the compiler | |
| 1817 bug which occurs when the probability of a (explainable) compiler bug is zero. | |
| 1818 Only wimps would use this option. The default is 0.01%. | |
| 1819 | |
| 1820 =item B<-I>I<path> / B<--include>=I<path> | |
| 1821 | |
| 1822 Adds a directory before the standard search path for compiler objects | |
| 1823 and source code. If a file is accessible from the current directory, | |
| 1824 it is never searched in any include path. | |
| 1825 | |
| 1826 If this option is repeated, the given paths will be searched in the | |
| 1827 order given, followed by the standard paths. | |
| 1828 | |
| 1829 =item B<-l>I<language> / B<--language>=I<language> | |
| 1830 | |
| 1831 Selects the language to use when interpreting user input. This should | |
| 1832 correspond to the name of a compiler, which is an INTERCAL object | |
| 1833 which was originally built by I<iacc>. Only the expression and | |
| 1834 statement parsers are used, so it is possible to test incomplete | |
| 1835 compilers by loading them into I<intercalc> even if they don't | |
| 1836 work with I<sick>. The default is obtained from the F<sickrc> | |
| 1837 option I<.INTERCALC.LANGUAGE>. | |
| 1838 | |
| 1839 =item -B<-o>I<option> -B<--option>=I<option> | |
| 1840 | |
| 1841 Adds a language option. For example, -B<-o>I<3> selects base 3 calculation, | |
| 1842 and -B<-o>I<wimp> selects wimp mode. If no options are provided, and the | |
| 1843 default language was taken from the F<sickrc> file, the default options | |
| 1844 are taken from the F<sickrc> file. Note that if an option or a language is | |
| 1845 specified on the command line, the F<sickrc> defaults are ignored. | |
| 1846 | |
| 1847 Unlike previous versions of I<intercalc>, this version checks that the | |
| 1848 options make sense in the context of the calculator; for example trying | |
| 1849 to load a compiler as an option will cause an error, but a compiler | |
| 1850 extension will be OK. | |
| 1851 | |
| 1852 =item B<-m>I<mode> / B<--mode>=I<mode> | |
| 1853 | |
| 1854 Select operation mode. Currently, the only valid modes are I<full>, | |
| 1855 I<expr> and I<one>. See L</Operating Modes>. If this is not specified, | |
| 1856 the default is taken from the F<sickrc> option I<..INTERCALC.MODE>. | |
| 1857 | |
| 1858 =back | |
| 1859 | |
| 1860 =head2 Misc Options | |
| 1861 | |
| 1862 =over 4 | |
| 1863 | |
| 1864 =item B<-r>I<name> / B<--rcfile>=I<name> | |
| 1865 | |
| 1866 Executes commands from file I<name> before starting to accept input. | |
| 1867 This option can be repeated, to execute more than one file. If it is | |
| 1868 not specified, the standard library, the current directory, and the | |
| 1869 current user's home directory are searched for files with name | |
| 1870 F<system.sickrc> or F<.sickrc>, which are then executed. The order | |
| 1871 for this search is: specified library (B<--include>), system library, | |
| 1872 home directory, current directory. This is different from the search | |
| 1873 order used when looking for objects or source code. If a directory | |
| 1874 contains both F<.sickrc> and F<system.sickrc>, the F<system.sickrc> | |
| 1875 is executed first, followed by F<.sickrc>. Also note that if the | |
| 1876 current directory or the home directory appear in the search path | |
| 1877 and contain one of these files, they will be executed twice. | |
| 1878 | |
| 1879 If filenames are explicitely specified, they must be fully qualified: | |
| 1880 the search path is not used to find them. | |
| 1881 | |
| 1882 =item B<--nouserrc> | |
| 1883 | |
| 1884 Prevents loading a user rcfile (.sickrc); also limits loading of | |
| 1885 system.sickrc to the first one found. This option is normally only | |
| 1886 used when testing the installation, to prevent interference from | |
| 1887 previous versions of CLC-INTERCAL. | |
| 1888 | |
| 1889 =back | |
| 1890 | |
| 1891 =head1 Operating Modes | |
| 1892 | |
| 1893 The calculator can operate in the following modes: | |
| 1894 | |
| 1895 =over 5 | |
| 1896 | |
| 1897 =item full | |
| 1898 Fully functional INTERCAL interpreter. | |
| 1899 | |
| 1900 The calculator can parse and execute any statement or expression. | |
| 1901 | |
| 1902 Statements are compiled as a one-statement program, and executed; | |
| 1903 any register value etc. will be preserved between statements, so | |
| 1904 entering a list of statements is equivalent to running a program | |
| 1905 in which all these statements are executed in sequence. | |
| 1906 | |
| 1907 It is important to note that some statements will not execute in | |
| 1908 the normal manner. For example, a COME FROM will be parsed but | |
| 1909 have no effect, unless it is something like: | |
| 1910 | |
| 1911 (1) PLEASE COME FROM (1) | |
| 1912 | |
| 1913 which causes the calculator to hang. On the other hand, an ABSTAIN FROM | |
| 1914 or a REINSTATE will work as expected, as will CREATE and DESTROY. | |
| 1915 A GIVE UP does not cause the calculator to terminate. One final | |
| 1916 difference is that comments are not parsed, and therefore you get a | |
| 1917 "Syntax Error" from the calculator rather than a splat *000 from the | |
| 1918 INTERCAL interpreter. | |
| 1919 | |
| 1920 For expressions, the calculator READs OUT the expression's result. | |
| 1921 Any side effects will be remembered, so if the expression contains | |
| 1922 overloads they will remain to haunt the calculator. | |
| 1923 | |
| 1924 =item expr | |
| 1925 INTERCAL expression interpreter | |
| 1926 | |
| 1927 The calculator can only parse expressions or assignments. In either | |
| 1928 case, the calculated values are READ OUT; assignments will also | |
| 1929 store the value to the destination, while expressions will then | |
| 1930 discard the result. | |
| 1931 | |
| 1932 =item oic | |
| 1933 The B<O>ne B<I>nstruction B<C>alculator. | |
| 1934 | |
| 1935 This is something we've made | |
| 1936 up one early morning while discussing desk calculators (as one does). | |
| 1937 It is not INTERCAL at all, in fact it is inspired from the One Instruction | |
| 1938 Set Computer. | |
| 1939 | |
| 1940 The calculator has a number of memories (default 100 - these can be changed | |
| 1941 by appending a number to the operating mode, for example I<oic10> will | |
| 1942 use a 10-memory calculator). These memories are identified by the letter | |
| 1943 B<m> followed by a number; in the default 100-memory version, the first two | |
| 1944 digits after B<m> are the memory, and any subsequent digit forms part | |
| 1945 of the next operand. At the start, all memories are initialised to 0. | |
| 1946 | |
| 1947 Since there is only one operation, there is no need to specify it, so an | |
| 1948 "operation" is a sequence of three operands and a result. The result must | |
| 1949 be a memory, while each operand can be a number or a memory, with the | |
| 1950 limitation that consecutive numbers are acceptable only if the parser can | |
| 1951 determine where one ends and the next one starts. So for example "1-0" is | |
| 1952 two numeric operands, 1 and -0 (aka 0); "1.2.3" is also two operands, | |
| 1953 1.2 and 3; "12" is a single operand, even if you intended it to be two | |
| 1954 operands, 1 and 2, and even if you put spaces: "1 2" is still interpreted | |
| 1955 as the single operand 12. | |
| 1956 | |
| 1957 The operation performed is the difference between the first two operands, | |
| 1958 divided by the third. For example, the three operations: | |
| 1959 | |
| 1960 7 m01 2 M01 | |
| 1961 1 m02 1 m02 | |
| 1962 m1 .5 m2 m03 | |
| 1963 | |
| 1964 will produce results m01=3.5 ((7-0)/2); m02=1 ((1-0)/1); m03=3 ((3.5-.5)/1). | |
| 1965 and will produce the following output if the calculator is running in batch | |
| 1966 mode: | |
| 1967 | |
| 1968 m01 3.5 (7 - m01) / 2 | |
| 1969 m02 1 (1 - m02) / 1 | |
| 1970 m03 3 (m01 - .5) / m02 | |
| 1971 | |
| 1972 =back | |
| 1973 | |
| 1974 =head1 SEE ALSO | |
| 1975 | |
| 1976 The INTERCAL on-line documentation, by running B<intercalc> and finding the | |
| 1977 "help" menu or key (X and Curses) or backspark escape (Line and None). | |
| 1978 |