clc-intercal 1:1.0~4pre1.-94.-2-3 / usr / share / perl5 / Language / INTERCAL / DataItem.pm

package Language::INTERCAL::DataItem;

# Base class for all data items (Arrays, Numbers, Whirlpool)

# 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/DataItem.pm 1.-94.-2") =~ /\s(\S+)$/;

use Carp;
use Language::INTERCAL::Exporter '1.-94.-2';
use Language::INTERCAL::Splats '1.-94.-2', qw(:SP);
use vars qw(@EXPORT);
@EXPORT = qw(_make_subscripts);

# note: _make_subscripts is exported, not accessed by inheriting it,
# because we sometimes want to call it without an object

sub _make_subscripts {
    my ($di, $subscripts, $zero_ok) = @_;
    return () if ! defined $subscripts;
    if (ref $subscripts) {
	if (UNIVERSAL::isa($subscripts, 'Language::INTERCAL::Arrays')) {
	    $subscripts = [ $subscripts->as_list() ];
	} elsif (UNIVERSAL::isa($subscripts, 'Language::INTERCAL::Numbers')) {
	    $subscripts = [ $subscripts->number() ];
	} elsif (ref $subscripts ne 'ARRAY') {
	    faint(SP_ARRAY, "Subscripts aren't numbers");
	}
    } else {
	$subscripts = [$subscripts];
    }
    my @subscripts = ();
    $zero_ok ||= $di->{zero_ok} if $di;
    my $min = $zero_ok ? 0 : 1;
    for my $s (@$subscripts) {
	if (ref $s) {
	    UNIVERSAL::isa($s, 'Language::INTERCAL::Numbers')
		or faint(SP_ARRAY, "Subscript is not a number");
	    $s = $s->number;
	    $s < $min || $s > 0xffff
		and faint(SP_ARRAY, "Subscript out of range");
	    push @subscripts, $s;
	} else {
	    $s =~ /^\d+$/
		or faint(SP_ARRAY, "Subscript is not a number");
	    $s < $min || $s > 0xffff
		and faint(SP_ARRAY, "Subscript out of range");
	    push @subscripts, $s;
	}
    }
    if ($di) {
	if (! exists $di->{subscripts}) {
	    faint(SP_NOARRAY) if @subscripts;
	    return ();
	}
	faint(SP_NODIM) unless @{$di->{subscripts}};
	@subscripts == @{$di->{subscripts}}
	    or faint(SP_SUBSIZE, scalar @subscripts,
				 scalar @{$di->{subscripts}});
	for (my $i = 0; $i < @subscripts; $i++) {
	    $subscripts[$i] >= $min
		or faint(SP_SUBSCRIPT, $subscripts[$i], 'too small');
	    $subscripts[$i] <= $di->{subscripts}[$i]
		or faint(SP_SUBSCRIPT, $subscripts[$i],
			 "is greater than $di->{subscripts}[$i]");
	}
    }
    @subscripts;
}

sub use {
    if (@_ == 2) {
	my ($di, $subs) = @_;
	if ($di->{overload} && ! $di->{in_overload}) {
	    $di->{in_overload} = 1;
	    my $r = &{$di->{overload}}($subs);
	    delete $di->{in_overload};
	    return $r;
	}
	my @s = _make_subscripts($di, $subs);
	return $di if ! @s;
	return $di->_get(\@s);
    }
    if (@_ == 3) {
	my ($di, $subs, $value) = @_;
	if ($di->{overload} && ! $di->{in_overload}) {
	    $di->{in_overload} = 1;
	    my $r = &{$di->{overload}}($subs, $value);
	    delete $di->{in_overload};
	    return $r;
	}
	my @s = _make_subscripts($di, $subs);
	return $di->_assign($value) if ! @s;
	return $di->_store(\@s, $value);
    }
    croak "Usage: DATA_ITEM->use(SUBSCRIPTS [, VALUE])";
}

sub assign {
    @_ == 2 or croak "Usage: DATA_ITEM->assign(VALUE)";
    my ($di, $value) = @_;
    if ($di->{overload} && ! $di->{in_overload}) {
	$di->{in_overload} = 1;
	my $r = &{$di->{overload}}([], $value);
	delete $di->{in_overload};
	return $r;
    }
    return $di->_assign($value);
}

sub value {
    @_ == 1 or croak "Usage: DATA_ITEM->value";
    my ($di) = @_;
    if ($di->{overload} && ! $di->{in_overload}) {
	$di->{in_overload} = 1;
	my $r = &{$di->{overload}}([]);
	delete $di->{in_overload};
	return $r;
    }
    return $di;
}

sub store {
    @_ == 3 or croak "Usage: DATA_ITEM->store(SUBSCRIPTS, VALUE)";
    my ($di, $subs, $value) = @_;
    if ($di->{overload} && ! $di->{in_overload}) {
	$di->{in_overload} = 1;
	my $r = &{$di->{overload}}($subs, $value);
	delete $di->{in_overload};
	return $r;
    }
    return $di->_store($subs, $value);
}

sub get {
    @_ == 2 or croak "Usage: DATA_ITEM->get(SUBSCRIPTS)";
    my ($di, $subs) = @_;
    if ($di->{overload} && ! $di->{in_overload}) {
	$di->{in_overload} = 1;
	my $r = &{$di->{overload}}($subs);
	delete $di->{in_overload};
	return $r;
    }
    return $di->_get($subs);
}

sub overload {
    @_ == 2 || @_ == 3
	or croak "Usage: DATAITEM->overload(SUBSCRIPTS [,CODE])";
    my ($di, $subs, $code) = @_;
    defined $code && ref $code ne 'CODE'
	and croak "CODE is not a code reference";
    if ($subs && @$subs) {
	$di->get($subs)->overload(undef, $code);
    } else {
	$di->{overload} = $code;
    }
    $di;
}

sub get_overload {
    @_ == 2 or croak "Usage: DATAITEM->get_overload(SUBSCRIPTS)";
    my ($di, $subs) = @_;
    if ($subs && @$subs) {
	return $di->get($subs)->get_overload(undef);
    } else {
	return $di->{overload};
    }
}

sub bits {
    @_ == 1 or croak "Usage: NUMBER->bits";
    my ($num) = @_;
    $num->{bits};
}

1;