Mercurial > repo
view interps/clc-intercal/CLC-INTERCAL-Base-1.-94.-2/blib/lib/Language/INTERCAL/Whirlpool.pm @ 9071:581584df6d82
<fizzie> revert 942e964c81c1
author | HackBot |
---|---|
date | Sun, 25 Sep 2016 20:17:31 +0000 |
parents | 859f9b4339e6 |
children |
line wrap: on
line source
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;