← Back to branch summary

~ubuntu-branches/ubuntu/trusty/clc-intercal/trusty-proposed

« back to all changes in this revision

Viewing changes to INTERCAL/SharkFin.pm

  • Committer: Bazaar Package Importer
  • Author(s): Mark Brown
  • Date: 2006-10-08 13:30:54 UTC
  • mfrom: (1.1.1 upstream) (3.1.1 dapper)
  • Revision ID: james.westby@ubuntu.com-20061008133054-fto70u71yoyltr3m
Tags: 1:1.0~2pre1.-94.-4.1-1
* New upstream release.
* Change to dh_installman.

Show diffs side-by-side

added added

removed removed

Lines of Context:
INTERCAL/SharkFin.pm
 
1
package Language::INTERCAL::SharkFin;
 
2
 
 
3
# Special version of Language::INTERCAL::Arrays used for "Shark Fin"
 
4
# registers
 
5
 
 
6
# This file is part of CLC-INTERCAL
 
7
 
 
8
# Copyright (c) 2006 Claudio Calvelli, all rights reserved.
 
9
 
 
10
# CLC-INTERCAL is copyrighted software. However, permission to use, modify,
 
11
# and distribute it is granted provided that the conditions set out in the
 
12
# licence agreement are met. See files README and COPYING in the distribution.
 
13
 
 
14
use strict;
 
15
use vars qw($PERVERSION);
 
16
$PERVERSION = "CLC-INTERCAL INTERCAL/SharkFin.pm 1.-94.-4";
 
17
 
 
18
use Carp;
 
19
 
 
20
use Language::INTERCAL::Exporter '1.-94.-4';
 
21
use Language::INTERCAL::Splats '1.-94.-4', qw(:SP);
 
22
use Language::INTERCAL::Arrays '1.-94.-4';
 
23
 
 
24
use vars qw(@ISA);
 
25
@ISA = qw(Language::INTERCAL::Arrays::Tail);
 
26
 
 
27
my %types = (
 
28
    vector => [\&_code_vector, \&_decode_vector],
 
29
);
 
30
 
 
31
sub new {
 
32
    @_ == 3 || @_ == 4
 
33
        or croak "Usage: Language::INTERCAL::SharkFin->new(TYPE, OBJECT [,VALUE])";
 
34
    my ($class, $type, $object, @value) = @_;
 
35
    exists $types{$type} or faint(SP_SPECIAL, "(type $type)");
 
36
    my $arr;
 
37
    if (@value) {
 
38
        @value = &{$types{$type}[0]}($object, @value);
 
39
        # note, we don't use SUPER here, rather we rebless later
 
40
        $arr = Language::INTERCAL::Arrays::Tail->from_list(\@value);
 
41
    } else {
 
42
        $arr = Language::INTERCAL::Arrays::Tail->new([]);
 
43
    }
 
44
    $arr->{sharkfin} = {
 
45
        object => $object,
 
46
        type => $types{$type}[0],
 
47
        typename => $type,
 
48
        decode => $types{$type}[1],
 
49
    };
 
50
    bless $arr, $class;
 
51
}
 
52
 
 
53
sub type {
 
54
    @_ == 1 or croak "Usage: SHARKFIN->type";
 
55
    my ($arr) = @_;
 
56
    $arr->{sharkfin}{typename};
 
57
}
 
58
 
 
59
sub _assign {
 
60
    @_ == 2 or croak "Usage: SHARKFIN->assign(VALUE)";
 
61
    my ($arr, $value) = @_;
 
62
    exists $arr->{sharkfin} or faint(SP_NOSPECIAL);
 
63
    $arr->{sharkfin}{type} or faint(SP_NOSPECIAL);
 
64
    my @value = &{$arr->{sharkfin}{type}}($arr->{sharkfin}{object}, $value);
 
65
    $arr->SUPER::_assign(@value ? [scalar @value] : []);
 
66
    for (my $i = 1; $i <= @value; $i++) {
 
67
        $arr->_store([$i], $value[$i - 1]);
 
68
    }
 
69
    $arr;
 
70
}
 
71
 
 
72
sub _get_number {
 
73
    my ($value) = @_;
 
74
    return $value->spot->number
 
75
        if ref $value && UNIVERSAL::isa($value, 'Language::INTERCAL::Numbers');
 
76
    return $value
 
77
        if ! ref $value && defined $value && $value =~ /^\d+$/;
 
78
    faint(SP_INVARRAY, 'Not a number');
 
79
}
 
80
 
 
81
sub _code_vector {
 
82
    my ($object, $value) = @_;
 
83
    if (ref $value) {
 
84
        return (( map { _get_number($_) } @$value ))
 
85
            if ref $value eq 'ARRAY';
 
86
        return ( $value->spot->number )
 
87
            if UNIVERSAL::isa($value, 'Language::INTERCAL::Numbers');
 
88
        return ((map { $_->spot->number } $value->tail->as_list))
 
89
            if UNIVERSAL::isa($value, 'Language::INTERCAL::Arrays');
 
90
        faint(SP_NOARRAY, "Not an array");
 
91
    }
 
92
    if (defined $value) {
 
93
        return (unpack('C*', $value));
 
94
    }
 
95
    faint(SP_NOARRAY, "Not an array");
 
96
}
 
97
 
 
98
sub _decode_vector {
 
99
    my ($object, $value) = @_;
 
100
    my @list = map { $_->number } $value->as_list;
 
101
    pop @list while @list && $list[-1] == 0;
 
102
    my $list = pack('C*', @list);
 
103
    $list =~ s/([\\'])/\\$1/g;
 
104
    $list = "'$list'" if $list =~ /['\s\\]/;
 
105
    $list;
 
106
}
 
107
 
 
108
sub print {
 
109
    @_ == 1 or croak "Usage: SHARKFIN->print";
 
110
    my ($arr) = @_;
 
111
    my $s = $arr->{sharkfin};
 
112
    return &{$s->{decode}}($s->{object}, $arr) if $s->{decode};
 
113
    $arr->SUPER::print;
 
114
}
 
115
 
 
116
sub range {
 
117
    @_ == 3 or croak "Usage: SHARKFIN->range(START, LEN)";
 
118
    my ($arr, $start, $len) = @_;
 
119
    # we just rebless it to a Tail and use their range()
 
120
    bless $arr, 'Language::INTERCAL::Arrays::Tail';
 
121
    $arr->range($start, $len);
 
122
}
 
123
 
 
124
1;