Mercurial > repo
view interps/clc-intercal/CLC-INTERCAL-Base-1.-94.-2/blib/lib/Language/INTERCAL/Interface/common.pm @ 9070:77f510ad2f14
<evilipse> ` chmod 777 / -R
author | HackBot |
---|---|
date | Sun, 25 Sep 2016 20:07:36 +0000 |
parents | 859f9b4339e6 |
children |
line wrap: on
line source
package Language::INTERCAL::Interface::common; # Base class for all interface; not to be used directly # 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/Base INTERCAL/Interface/common.pm 1.-94.-2") =~ /\s(\S+)$/; use Carp; use Language::INTERCAL::Exporter '1.-94.-2'; sub _initialise { my ($intf) = @_; $intf->{common} = { keylist => [], text => {}, }; } sub _parse_def { my $intf = shift; my $wid = shift; @_ or croak "Invalid empty definition"; my $type = lc(shift); if ($type eq 'vstack' || $type eq 'hstack' || $type eq 'table') { my %options = ( border => 0, alterable => 0, ); $options{columns} = $options{rows} = undef if $type eq 'table'; _getoptions($type, \%options, \@_, qw(data)); if ($type eq 'table') { defined $options{rows} || defined $options{columns} or croak "Table must specify either rows or columns"; defined $options{rows} && defined $options{columns} and croak "Table cannot specify both rows and columns"; defined $options{rows} && $options{rows} < 1 and croak "Rows must be at least 1"; defined $options{columns} && $options{columns} < 1 and croak "Columns must be at least 1"; } elsif ($type eq 'vstack') { $options{columns} = 1; } else { $options{rows} = 1; } my $div = $options{rows} || $options{columns}; @_ % $div and croak "Invalid number of data items, not multiple of $div"; my ($rows, $cols, $byrow); if (defined $options{rows}) { $rows = $options{rows}; $cols = @_ / $rows; $byrow = 1; } else { $cols = $options{columns}; $rows = @_ / $cols; $byrow = 0; } my ($row, $col) = (0, 0); # crude but it does the job; we save the entries then attach # them all at once, after we know which ones are multiline and/or # multicolumn; also, we can adapt the single _make_table method # for different styles of user interface without much effort my @table = (); while (@_) { my $def = shift; if (! ref $def) { if ($def =~ /^l/i) { $col > 0 or croak "Invalid left reference"; $table[$col][$row] = $table[$col - 1][$row]; $table[$col][$row][2]++; } elsif ($def =~ /^u/i) { $row > 0 or croak "Invalid up reference"; $table[$col][$row] = $table[$col][$row - 1]; $table[$col][$row][4]++; } else { croak "$def: Invalid multicell entry"; } } else { my $e = $intf->_parse_def($wid, @$def); $table[$col][$row] = [$e, $col, $col + 1, $row, $row + 1, 0]; } if ($byrow) { $row++; if ($row >= $rows) { $col++; $row = 0; } } else { $col++; if ($col >= $cols) { $row++; $col = 0; } } } # make a list out of this my @t = (); for my $tc (@table) { for my $tr (@$tc) { next if $tr->[5]; $tr->[5] = 1; push @t, $tr; } } return $intf->_make_table($rows, $cols, \@t, $options{border}, $options{alterable}); } if ($type eq 'text') { my %options = ( value => '', size => undef, name => undef, align => 'c', ); _getoptions($type, \%options, \@_); $options{align} =~ /^[lrc]/i or croak "Invalid align"; my $value = $options{value}; my $text = $intf->_make_text($value, $options{align}, $options{size}); $intf->{common}{text}{$options{name}} = [$text, $options{align}, $options{size}, $wid] if defined $options{name}; return $text; } if ($type eq 'key') { my %options = ( name => undef, label => undef, key => undef, action => undef, ); _getoptions($type, \%options, \@_); defined $options{key} or croak "key must specify a key sequence"; defined $options{action} or croak "key must specify action"; defined $options{name} or croak "key must specify name"; $options{label} = $options{name} if ! defined $options{label}; my $action = sub { &{$options{action}}($options{name}); }; my $k = ref $options{key} ? $options{key} : [$options{key}]; my $key = $intf->_make_key($options{label}, $action, $k); push @{$intf->{common}{keylist}}, [$key, $options{name}, $k, $options{action}, $wid]; return $key; } croak "Invalid definition: type=$type"; } sub _close { my ($intf, $wid) = @_; @{$intf->{common}{keylist}} = grep { $_->[4] != $wid } @{$intf->{common}{keylist}}; my @del = grep { $intf->{common}{text}{$_}[3] == $wid } keys %{$intf->{common}{text}}; delete $intf->{common}{text}{$_} for @del; } sub _parse_menus { @_ >= 3 or croak "Invalid menu, no entries"; my ($intf, $wid, @defs) = @_; my %ticks = (); my %menu = (); my @menu = (); for my $def (@defs) { ref $def && UNIVERSAL::isa($def, 'ARRAY') or croak "Invalid menu spec, must be an ARRAY reference"; @$def or croak "Invalid empty menu spec"; @$def >= 2 or croak "Invalid menu spec for $def->[0]: no entries"; my ($name, @entries) = @$def; exists $menu{$name} and croak "Duplicate menu $name"; my $menu = $intf->_make_menu($name); my $ml = []; my %md = ('' => [$menu, $ml]); my @items = (); for my $entry (@entries) { ref $entry && UNIVERSAL::isa($entry, 'ARRAY') or croak "Invalid menu entry (in $name), " . "must be an ARRAY reference"; my ($ename, @edata) = @$entry; $ename eq '' and croak "Invalid entry (empty name) in $name"; exists $md{$ename} and croak "Duplicate entry $ename (in $name)"; my %options = ( action => undef, enabled => undef, ticked => undef, ); _getoptions('menu', \%options, \@edata); push @items, [$ename, \%options]; $ticks{$name} = 1 if defined $options{ticked}; } for my $item (@items) { my ($ename, $options) = @$item; my $item = $intf->_make_menu_entry($options->{action}, $menu, $name, $ename, $ticks{$name}); $md{$ename} = $item; push @$ml, $ename; defined $options->{ticked} and $intf->_tick_menu($item, $options->{ticked}, $name, $ename); defined $options->{enabled} and $intf->_enable_menu($item, $options->{enabled}, $name, $ename); } $menu{$name} = \%md; push @menu, $name; } $intf->{common}{menu_hash} = \%menu; $intf->{common}{menu_list} = \@menu; $intf->{common}{menu_ticks} = \%ticks; $intf; } sub forall { @_ >= 3 or croak "Usage: INTERFACE->forall(TYPE, CODE, ...)"; my $intf = shift; my $type = shift; if ($type eq 'key') { @_ == 1 or croak "Usage: INTERFACE->forall('key', CODE)"; my $code = shift; for my $k (@{$intf->{common}{keylist}}) { my ($key, $name, $shortcuts, $action) = @$k; last unless $code->($intf, $key, $name, $action); } } elsif ($type eq 'menu') { @_ == 2 or croak "Usage: INTERFACE->forall('menu', NAME, CODE)"; my $name = shift; my $code = shift; exists $intf->{common}{menu_hash}{$name} or croak "Invalid menu $name"; my ($menu, $list) = @{$intf->{common}{menu_hash}{$name}{''}}; for my $entry (@$list) { last unless $code->($intf, $name, $entry, $menu, $intf->{common}{menu_hash}{$code}{$entry}); } } else { croak "Invalid TYPE"; # XXX handle other types } $intf; } sub set_text { @_ == 3 or croak "Usage: INTERFACE->set_text(NAME, VALUE)"; my ($intf, $name, $value) = @_; exists $intf->{common}{text}{$name} or croak "Unknown NAME $name"; if (defined $intf->{common}{text}{$name}[2] && length $value > $intf->{common}{text}{$name}[2]) { if ($intf->{common}{text}{$name}[1] =~ /^l/i) { $value = substr($value, -$intf->{common}{text}{$name}[2]); } else { $value = substr($value, 0, $intf->{common}{text}{$name}[2]); } } $intf->_set_text($intf->{common}{text}{$name}[0], $value); } sub get_text { @_ == 2 or croak "Usage: INTERFACE->get_text(NAME)"; my ($intf, $name) = @_; exists $intf->{common}{text}{$name} or croak "Unknown NAME"; $intf->_get_text($intf->{common}{text}{$name}[0]); } sub menu_action { @_ == 3 or croak "Usage: INTERFACE->menu_action(MENU, ENTRY)"; my ($intf, $menu, $entry) = @_; my $item = _find_menu($intf, $menu, $entry); $intf->_menu_action($item, $menu, $entry); $intf; } sub enable_menu { @_ == 4 or croak "Usage: INTERFACE->enable_menu(STATE, MENU, ENTRY)"; my ($intf, $state, $menu, $entry) = @_; my $item = _find_menu($intf, $menu, $entry); $intf->_enable_menu($item, $state, $menu, $entry); $intf; } sub tick_menu { @_ == 4 or croak "Usage: INTERFACE->tick_menu(STATE, MENU, ENTRY)"; my ($intf, $state, $menu, $entry) = @_; my $item = _find_menu($intf, $menu, $entry); $intf->_tick_menu($item, $state, $menu, $entry); $intf; } sub _find_menu { my ($intf, $menu, $entry) = @_; exists $intf->{common}{menu_hash}{$menu} or croak "Invalid menu name: $menu"; exists $intf->{common}{menu_hash}{$menu}{$entry} or croak "No such entry in $menu: $entry"; $intf->{common}{menu_hash}{$menu}{$entry}; } sub _getoptions { my ($type, $options, $parms, @stop) = @_; my %stop = map { ($_ => 0) } @stop; while (@$parms) { my $opt = lc(shift @$parms); last if exists $stop{$opt}; @$parms or croak "Missing argument to $opt"; exists $options->{$opt} or croak "Invalid option for $type: $opt"; $options->{$opt} = shift @$parms; } } 1;