File Coverage

blib/lib/Language/Basic/Variable.pm
Criterion Covered Total %
statement 70 73 95.8
branch 18 22 81.8
condition 1 3 33.3
subroutine 12 12 100.0
pod 0 1 0.0
total 101 111 90.9


line stmt bran cond sub pod time code
1             package Language::Basic::Variable;
2              
3             # Part of Language::Basic by Amir Karger (See Basic.pm for details)
4              
5             =pod
6              
7             =head1 NAME
8              
9             Language::Basic::Variable - Module to handle parsing and implementing
10             BASIC variables.
11              
12             =head1 SYNOPSIS
13              
14             See L for the overview of how the Language::Basic module
15             works. This pod page is more technical.
16              
17             There are two sorts of variables: Arrays and Scalars. Each of those
18             classes has a subclass for Numeric or String variables.
19              
20             =head1 DESCRIPTION
21              
22             An Array needs to have full LBV::Scalar objects in it, rather than just
23             having an array of values. The reason is that, for example, you might
24             use ARR(3) as the variable in a FOR loop. Also, the "set" and "value"
25             methods apply to a LBV::Scalar (since you can't set an array to a value
26             (in BASIC :)) so in order to be handle A(3)=3, A(3) needs to be an LBV::Scalar.
27              
28             The lookup method looks up a variable in the Array or Scalar lookup
29             table (depending on whether there were parentheses after the variable
30             name). BASIC allows undeclared variables, so if the variable name hasn't
31             been seen before, a new variable is created.
32              
33             =cut
34              
35 16     16   91 use strict;
  16         31  
  16         17110  
36              
37             # sub-packages
38             {
39             package Language::Basic::Variable;
40             package Language::Basic::Variable::Numeric;
41             package Language::Basic::Variable::String;
42             package Language::Basic::Variable::Scalar;
43             package Language::Basic::Variable::Array;
44             }
45             # Hash storing the program's variables
46             my %Scalars;
47             my %Arrays;
48              
49             # Look up a variable based on its name.
50             # Create a new Variable (Scalar or Array) if it doesn't yet exist.
51             # Arg0 is the name for the variable, Arg1 is defined if there were () after
52             # the name, i.e., if it's an array. For now, we don't care what's in the
53             # parens.
54             # Returns the Variable ref, whether or not it had to create a new one.
55             sub lookup {
56 90     90 0 314 my $name = shift;
57 90         151 my $arglist = shift;
58 90 100       182 if (defined($arglist)) {
59 13 100       36 unless (exists $Arrays{$name}) {
60 5         23 $Arrays{$name} = new Language::Basic::Variable::Array $name;
61             }
62 13         44 return $Arrays{$name};
63             } else {
64 77 100       323 unless (exists $Scalars{$name}) {
65 23         156 $Scalars{$name} = new Language::Basic::Variable::Scalar $name;
66             }
67 77         245 return $Scalars{$name};
68             }
69             } # end sub Language::Basic::Variable::lookup
70              
71             ######################################################################
72             # package Language::Basic::Variable::Scalar
73             #
74             # Fields:
75             # value - the current value of the variable
76             #
77              
78             =head2 Language::Basic::Variable::Scalar class
79              
80             This class handles a variable or one cell in an array.
81              
82             Methods include "value", which gets the variable's value, and "set",
83             which sets it.
84              
85             =cut
86              
87             {
88             package Language::Basic::Variable::Scalar;
89             @Language::Basic::Variable::Scalar::ISA = qw(Language::Basic::Variable);
90              
91             sub new {
92 23     23   51 my ($class, $name) = @_;
93 23 100       97 my $type = ($name =~ /\$$/) ? "String" : "Numeric";
94             # Create a new subclass object, & return it
95 23         67 my $subclass = $class . "::$type";
96 23         121 return (new $subclass);
97             } # end sub Language::Basic::Variable::new
98              
99             # Set the variable to value arg1
100             sub set {
101 160     160   248 my ($self, $value) = @_;
102 160         717 $self->{"value"} = $value;
103             }
104              
105 264     264   713 sub value {return shift->{"value"} }
106              
107             package Language::Basic::Variable::Scalar::String;
108             @Language::Basic::Variable::Scalar::String::ISA =
109             qw (Language::Basic::Variable::Scalar Language::Basic::Variable::String);
110              
111             sub new {
112 15     15   21 my $class = shift;
113 15         21 my $value = "";
114 15         34 my $self = {
115             "value" => $value,
116             };
117 15         57 bless $self, $class;
118             } # end sub Language::Basic::Variable::Scalar::String::new
119              
120             package Language::Basic::Variable::Scalar::Numeric;
121             @Language::Basic::Variable::Scalar::Numeric::ISA =
122             qw (Language::Basic::Variable::Scalar Language::Basic::Variable::Numeric);
123              
124             sub new {
125 212     212   230 my $class = shift;
126 212         293 my $value = 0;
127 212         453 my $self = {
128             "value" => $value,
129             };
130 212         699 bless $self, $class;
131             } # end sub Language::Basic::Variable::Scalar::Numeric::new
132              
133             } # end package Language::Basic::Variable::Scalar
134              
135             ######################################################################
136             #
137             # Fields:
138             # cells - list (of lists, for 2- or more dimensional arrays) of
139             # Language::Basic::Variable::Scalar objects holding the actual values
140             # for each index
141              
142             =head2 Language::Basic::Variable::Array class
143              
144             This class handles a BASIC array. Each cell in the array is a LBV::Scalar
145             object.
146              
147             Methods include "dimension", which dimensions the array to a given size (or
148             a default size) and get_cell, which returns the LBV::Scalar object in a
149             given array location.
150              
151             Note that BASIC arrays start from 0!
152              
153             =cut
154              
155             {
156             package Language::Basic::Variable::Array;
157             @Language::Basic::Variable::Array::ISA = qw(Language::Basic::Variable);
158 16     16   132 use Language::Basic::Common;
  16         33  
  16         15376  
159              
160             # Fields:
161             # cells - holds the LBV::Scalar::* objects in the array
162              
163             # Note that this returns subclasses of LBVA (String or Numeric)
164             sub new {
165 5     5   10 my ($class, $name) = @_;
166 5         21 my $self = {
167             "cells" => [],
168             };
169              
170 5 100       21 my $type = ($name =~ /\$$/) ? "String" : "Numeric";
171 5         10 my $subclass = $class . "::$type";
172 5         19 bless $self, $subclass;
173              
174             # Dimension the array to its default size
175 5         35 $self->dimension;
176 5         16 return $self;
177             } # end sub Language::Basic::Variable::Array::new
178              
179             # Make room in the array
180             # Input: Optionally, a list of sizes for each dimension. Otherwise, a
181             # one-dimensional array of default size is dimensioned.
182             # Error: Exit with error if the array will be too big.
183             sub dimension {
184 8     8   13 my $MAXDIM = 100000;
185 8         10 my $self = shift;
186 8         15 my @Default = (10);
187              
188             # TODO multi-dim arrays
189 8 100       38 my @sizes = @_ ? @_ : @Default;
190 8         12 my $size = 1;
191 8         18 for (@sizes) {$size *= ($_+1)}
  10         26  
192 8 50       24 if ($size > $MAXDIM)
  0         0  
193             {&Exit_Error("Array size may not be greater than $MAXDIM")}
194              
195 8         17 my $subclass = ref($self);
196 8         31 $subclass =~ s/Array/Scalar/;
197 8         24 $self->{"cells"} = &lol($subclass, @sizes);
198 8         88 $self->{"dimensions"} = \@sizes;
199             } # end sub Language::Basic::Variable::Array::dimension
200              
201             sub lol {
202             # create a list of lists of arg0 objects, dimensions arg1-n
203 224     224   305 my ($subclass, @sizes) = @_;
204 224 100       377 if (@sizes) {
205             #recurse
206 20         28 my $size = shift(@sizes);
207 20         50 my @arr = map {&lol($subclass, @sizes)} (0 .. $size);
  216         383  
208 20         96 return \@arr;
209             } else {
210             # end recursion
211             # '$subclass->new' because 'new $subclass' calls LBVA::new!
212 204         393 my $ret = $subclass->new;
213 204         464 return $ret;
214             }
215             } # end sub Language::Basic::Variable::Array::lol
216              
217             # Get one cell of an array
218             # Input: a list of array indices
219             # Output: the Language::Basic::Variable::Scalar at that location in the array
220             sub get_cell {
221 54     54   75 my $self = shift;
222 54         79 my @indices = @_;
223 54         52 my @sizes = @{$self->{"dimensions"}};
  54         113  
224 54 50       240 unless (@sizes == @indices) {Exit_Error("Wrong number of indices!")}
  0         0  
225              
226 54         87 my $ptr = $self->{"cells"};
227 54         85 foreach my $index (@indices) {
228 58         74 my $size = shift(@sizes);
229             # index can't be negative or greater than the array size
230 58 50 33     408 if ($index !~ /^\d+$/ || $index > $size) {
231 0         0 &Exit_Error ("Illegal array indexing '@indices'")
232             }
233 58         168 $ptr = $ptr->[$index];
234             }
235              
236 54         103 my $c = ref($ptr);
237 54 50       203 warn "Weird class $c" unless $ptr->isa("Language::Basic::Variable::Scalar");
238 54         309 return $ptr;
239             } # end sub Language::Basic::Variable::Array::get_cell
240              
241             package Language::Basic::Variable::Array::Numeric;
242             @Language::Basic::Variable::Array::Numeric::ISA =
243             qw (Language::Basic::Variable::Array Language::Basic::Variable::Numeric);
244             package Language::Basic::Variable::Array::String;
245             @Language::Basic::Variable::Array::String::ISA =
246             qw (Language::Basic::Variable::Array Language::Basic::Variable::String);
247             } # end package Language::Basic::Variable::Array
248              
249             {
250             # set ISA for "return type" classes
251             package Language::Basic::Variable::Numeric;
252             @Language::Basic::Variable::Numeric::ISA = qw
253             (Language::Basic::Variable Language::Basic::Numeric);
254             package Language::Basic::Variable::String;
255             @Language::Basic::Variable::String::ISA = qw
256             (Language::Basic::Variable Language::Basic::String);
257             }
258             1; # end package Language::Basic::Variable