package Language::INTERCAL::Whirlpool;

# Classes, lectures and filehandles. Yes, they all get stored in the same
# place.

# 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/Whirlpool.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 Language::INTERCAL::Numbers '1.-94.-2';
use Language::INTERCAL::Arrays '1.-94.-2';
use Language::INTERCAL::DataItem '1.-94.-2';
use Language::INTERCAL::GenericIO '1.-94.-2';
use vars qw(@ISA);
@ISA = qw(Language::INTERCAL::DataItem);

sub new {
    @_ == 1 || @_ == 2
	or croak "Usage: new Language::INTERCAL::Whirlpool [VALUE]";
    my ($class, $value) = @_;
    if (defined $value) {
	ref $value or faint(SP_NOCLASS, $value);
	if (UNIVERSAL::isa($value, 'Language::INTERCAL::Whirlpool')) {
	    $value = $value->filehandle;
	} elsif (! UNIVERSAL::isa($value, 'Language::INTERCAL::GenericIO')) {
	    faint(SP_NOCLASS, $value);
	}
    }
    bless {
	filehandle => $value,
	subjects => {},
	overload => undef,
	bits => 16,
	subscripts => [65535],
    }, $class;
}

sub nuke {
    @_ == 1 or croak "Usage: CLASS->nuke()";
    my ($whp) = @_;
    $whp->{filehanle} = undef;
    $whp->{subjects} = {};
    $whp->{overload} = undef;
    $whp;
}

sub filehandle {
    @_ == 1 or croak "Usage: CLASS->filehandle";
    my ($whp) = @_;
    $whp->{filehandle};
}

sub copy {
    @_ == 1 or croak "Usage: CLASS->copy";
    my ($whp) = @_;
    bless {
	filehandle => $whp->{filehandle},
	subjects => {%{$whp->{subjects}}},
	overload => $whp->{overload},
	bits => 16,
	subscripts => [65535],
    }, ref $whp;
}

sub _store {
    @_ == 3 or croak "Usage: CLASS->store(SUBSCRIPT, VALUE)";
    my ($whp, $subscript, $value) = @_;
    my $lab;
    if (ref $value) {
	UNIVERSAL::isa($value, 'Language::INTERCAL::Numbers')
	    or faint(SP_INVCLASS, 'Not a number');
	$lab = $value->spot->number;
    } else {
	defined $value && $value =~ /^\d+$/
	    or faint(SP_INVCLASS, 'Not a number');
	$lab = $value;
    }
    $lab >= 1000 or faint(SP_EARLY, $lab);
    if (exists $whp->{subjects}{$subscript->[0]}) {
	$whp->{subjects}{$subscript->[0]}->assign($lab);
    } else {
	$whp->{subjects}{$subscript->[0]} =
	    Language::INTERCAL::Numbers::Spot->new($lab);
    }
    $whp;
}

sub _get {
    @_ == 2 or croak "Usage: CLASS->get(SUBSCRIPT)";
    my ($whp, $subscript) = @_;
    exists $whp->{subjects}{$subscript->[0]}
	or faint(SP_CLASS, '#' . $subscript->[0]);
    $whp->{subjects}{$subscript->[0]};
}

sub _assign {
    @_ == 2 or croak "Usage: CLASS->assign(VALUE)";
    my ($whp, $value) = @_;
    if (defined $value) {
	ref $value or faint(SP_NOCLASS, $value);
	if (UNIVERSAL::isa($value, 'Language::INTERCAL::Whirlpool')) {
	    $value = $value->filehandle;
	} elsif (! UNIVERSAL::isa($value, 'Language::INTERCAL::GenericIO')) {
	    faint(SP_NOCLASS, $value);
	}
    }
    $whp->{filehandle} = $value;
    $whp;
}

# a few methods so that a class can be used as an array

sub tail {
    @_ == 1 or croak "Usage: CLASS->tail";
    my ($whp) = @_;
    my $t = new Language::INTERCAL::Arrays::Tail 65535;
    for my $k (keys %{$whp->{subjects}}) {
	next if $k == 0;
	my $v = $whp->{subjects}{$k};
	$t->store($k, $v);
    }
    $t;
}

sub hybrid {
    @_ == 1 or croak "Usage: CLASS->hybrid";
    my ($whp) = @_;
    my $h = new Language::INTERCAL::Arrays::Hybrid 65535;
    for my $k (keys %{$whp->{subjects}}) {
	next if $k == 0;
	my $v = $whp->{subjects}{$k};
	$h->store($k, $v);
    }
    $h;
}

# some methods in case classes are used where they don't belong

sub as_list { faint(SP_ISCLASS) }
sub as_string { faint(SP_ISCLASS) }
sub digits { faint(SP_ISCLASS) }
sub elements { faint(SP_ISCLASS) }
sub number { faint(SP_ISCLASS) }
sub range { faint(SP_ISCLASS) }
sub spot { faint(SP_ISCLASS) }
sub twospot { faint(SP_ISCLASS) }

1;