File Coverage

blib/lib/PDL/Char.pm
Criterion Covered Total %
statement 98 101 97.0
branch 28 38 73.6
condition 9 11 81.8
subroutine 9 10 90.0
pod 4 5 80.0
total 148 165 89.7


line stmt bran cond sub pod time code
1             package PDL::Char;
2              
3             @ISA = qw (PDL);
4 1     1   572 use overload ("\"\"" => \&PDL::Char::string);
  1         2  
  1         9  
5 1     1   64 use strict;
  1         2  
  1         26  
6 1     1   5 use vars ('$level', '@dims'); # Global Vars used
  1         3  
  1         1308  
7              
8              
9             =head1 NAME
10              
11             PDL::Char -- PDL subclass which allows reading and writing of fixed-length character strings as byte PDLs
12              
13             =head1 SYNOPSIS
14              
15             use PDL;
16             use PDL::Char;
17              
18             my $pchar = PDL::Char->new( [['abc', 'def', 'ghi'],['jkl', 'mno', 'pqr']] );
19            
20             $pchar->setstr(1,0,'foo');
21            
22             print $pchar; # 'string' bound to "", perl stringify function
23             # Prints:
24             # [
25             # ['abc' 'foo' 'ghi']
26             # ['jkl' 'mno' 'pqr']
27             # ]
28              
29             print $pchar->atstr(2,0);
30             # Prints:
31             # ghi
32              
33             =head1 DESCRIPTION
34              
35             This subclass of PDL allows one to manipulate PDLs of 'byte' type as if they were made of fixed
36             length strings, not just numbers.
37              
38             This type of behavior is useful when you want to work with charactar grids. The indexing is done
39             on a string level and not a character level for the 'setstr' and 'atstr' commands.
40              
41             This module is in particular useful for writing NetCDF files that include character data using the
42             PDL::NetCDF module.
43              
44             =head1 FUNCTIONS
45              
46             =head2 new
47              
48             =for ref
49              
50             Function to create a byte PDL from a string, list of strings, list of list of strings, etc.
51              
52             =for usage
53              
54             # create a new PDL::Char from a perl array of strings
55             $strpdl = PDL::Char->new( ['abc', 'def', 'ghij'] );
56              
57             # Convert a PDL of type 'byte' to a PDL::Char
58             $strpdl1 = PDL::Char->new (sequence (byte, 4, 5)+99);
59              
60             =for example
61              
62             $pdlchar3d = PDL::Char->new([['abc','def','ghi'],['jkl', 'mno', 'pqr']]);
63              
64             =cut
65              
66              
67             sub new {
68 3     3 1 720 my $type = shift;
69 3 50       14 my $value = (scalar(@_)>1 ? [@_] : shift); # ref thyself
70              
71             # re-bless byte PDLs as PDL::Char
72 3 100       16 if (ref($value) =~ /PDL/) {
73 1 50       6 PDL::Core::barf('Cannot convert a non-byte PDL to PDL::Char')
74             if ($value->get_datatype != $PDL::Types::PDL_B);
75 1         5 return bless $value, $type;
76             }
77              
78 2         4 my $ptype = $PDL::Types::PDL_B;
79 2         71 my $self = PDL->initialize();
80 2         35 $self->set_datatype($ptype);
81 2 50       9 $value = 0 if !defined($value);
82 2         4 $level = 0; @dims = (); # package vars
  2         6  
83 2         3 my $maxlength; # max length seen for all character strings
84 2         3 my $samelen = 1; # Flag = 1 if all character strings are the same length
85              
86             # 1st Pass thru the perl array structure, assume all strings the same length
87 2         9 my $str = _rcharpack($value,\$maxlength,\$samelen);
88 2 100       14 unless( $samelen){ # Strings weren't the same length, go thru again and null pad to
89             # the max length.
90 1         4 $str = _rcharpack2($value,$maxlength);
91             }
92 2         29 $self->setdims([reverse @dims]);
93 2         5 ${$self->get_dataref} = $str;
  2         13  
94 2         8 $self->upd_data();
95 2         8 return bless $self, $type;
96             }
97            
98             # Take an N-D perl array of strings and pack it into a single string,
99             # updating the $level and @dims package vars on the way.
100             # Used by the 'char' constructor
101             #
102             # References supplied so $maxlength and $samelen are updated along the way as well.
103             #
104             #
105             # This version (_rcharpack) is for the 1st pass thru the N-d string array.
106             # It assumes that all strings are the same length, but also checks to see if they aren't
107             sub _rcharpack {
108              
109 28     28   31 my $w = shift; # Input string
110 28         46 my ($maxlenref, $samelenref) = @_; # reference to $maxlength, $samelen
111              
112 28         36 my ($ret,$type);
113            
114 28         34 $ret = "";
115 28 100       59 if (ref($w) eq "ARRAY") {
    50          
116              
117 10 50 66     30 PDL::Core::barf('Array is not rectangular') if (defined($dims[$level]) and
118             $dims[$level] != scalar(@$w));
119 10         16 $dims[$level] = scalar (@$w);
120 10         12 $level++;
121            
122 10         21 $type = ref($$w[0]);
123 10         15 for(@$w) {
124 26 50       49 PDL::Core::barf('Array is not rectangular') unless $type eq ref($_); # Equal types
125 26         43 $ret .= _rcharpack($_,$maxlenref, $samelenref);
126             }
127            
128 10         15 $level--;
129            
130             }elsif (ref(\$w) eq "SCALAR") {
131 18         22 my $len = length($w);
132              
133             # Check for this length being different then the others:
134 18 100 100     56 $$samelenref = 0 if( defined($$maxlenref) && ($len != $$maxlenref) );
135             # Save the max length:
136 18 100 66     52 $$maxlenref = $len if( !defined($$maxlenref) || $len > $$maxlenref); # see if this is the max length seen so far
137              
138 18         23 $dims[$level] = $len;
139 18         22 $ret = $w;
140            
141             }else{
142 0         0 PDL::Core::barf("Don't know how to make a PDL object from passed argument");
143             }
144 28         61 return $ret;
145             }
146             #
147             #
148             # This version (_rcharpack2) is for the 2nd pass (if required) thru the N-d string array.
149             # If the 1st pass thru (_rcharpack) finds that all strings were not the same length,
150             # this routine will go thru and null-pad all strings to the max length seen.
151             # Note: For efficiency, the error checking is not repeated here, because any errors will
152             # already be detected in the 1st pass.
153             #
154             sub _rcharpack2 {
155              
156 9     9   12 my $w = shift; # Input string
157 9         14 my ($maxlen) = @_; # Length to pad strings to
158              
159 9         13 my ($ret,$type);
160            
161 9         13 $ret = "";
162 9 100       23 if (ref($w) eq "ARRAY") {
    50          
163              
164             # Checks not needed the second time thru (removed)
165              
166 3         6 $dims[$level] = scalar (@$w);
167 3         4 $level++;
168            
169 3         4 $type = ref($$w[0]);
170 3         7 for(@$w) {
171 8         17 $ret .= _rcharpack2($_,$maxlen);
172             }
173            
174 3         3 $level--;
175            
176             }elsif (ref(\$w) eq "SCALAR") {
177 6         9 my $len = length($w);
178              
179 6         9 $dims[$level] = $maxlen;
180 6         12 $ret = $w.("\00" x ($maxlen - $len));
181             }
182 9         54 return $ret;
183             }
184              
185              
186             #
187             #
188              
189             =head2 string
190              
191             =for ref
192              
193             Function to print a character PDL (created by 'char') in a pretty format.
194              
195             =for usage
196              
197             $char = PDL::Char->new( [['abc', 'def', 'ghi'], ['jkl', 'mno', 'pqr']] );
198             print $char; # 'string' bound to "", perl stringify function
199             # Prints:
200             # [
201             # ['abc' 'def' 'ghi']
202             # ['jkl' 'mno' 'pqr']
203             # ]
204              
205             # 'string' is overloaded to the "" operator, so:
206             # print $char;
207             # should have the same effect.
208              
209             =cut
210              
211             sub string {
212 34     34 1 97 my $self = shift;
213 34   100     70 my $level = shift || 0;
214              
215 34 50       58 my $sep = $PDL::use_commas ? "," : " ";
216              
217 34 100       73 if ($self->dims == 1) {
218 23         34 my $str = ${$self->get_dataref}; # get copy of string
  23         124  
219 23         62 $str =~ s/\00+$//g; # get rid of any null padding
220 23         196 return "\'". $str. "\'". $sep;
221             } else {
222 11         23 my @dims = reverse $self->dims;
223 11         22 my $ret = '';
224 11 100       43 $ret .= (" " x $level) . '[' . ((@dims == 2) ? ' ' : "\n");
225 11         29 for (my $i=0;$i<$dims[0];$i++) {
226 31         92 my $slicestr = ":," x (scalar(@dims)-1) . "($i)";
227 31         80 my $substr = $self->slice($slicestr);
228 31         98 $ret .= $substr->string($level+1);
229             }
230 11         29 $ret .= (" " x $level) . ']' . $sep . "\n";
231 11         118 return $ret;
232             }
233            
234             }
235              
236              
237             =head2 setstr
238              
239             =for ref
240              
241             Function to set one string value in a character PDL. The input position is
242             the position of the string, not a character in the string. The first dimension
243             is assumed to be the length of the string.
244              
245             The input string will be null-padded if the string is shorter than the first
246             dimension of the PDL. It will be truncated if it is longer.
247              
248             =for usage
249              
250             $char = PDL::Char->new( [['abc', 'def', 'ghi'], ['jkl', 'mno', 'pqr']] );
251             $char->setstr(0,1, 'foobar');
252             print $char; # 'string' bound to "", perl stringify function
253             # Prints:
254             # [
255             # ['abc' 'def' 'ghi']
256             # ['foo' 'mno' 'pqr']
257             # ]
258             $char->setstr(2,1, 'f');
259             print $char; # 'string' bound to "", perl stringify function
260             # Prints:
261             # [
262             # ['abc' 'def' 'ghi']
263             # ['foo' 'mno' 'f'] -> note that this 'f' is stored "f\0\0"
264             # ]
265              
266             =cut
267              
268             sub setstr { # Sets a particular single value to a string.
269 3 50   3 1 853 PDL::Core::barf('Usage: setstr($pdl, $x, $y,.., $value)') if $#_<2;
270 3         7 my $self = shift;
271 3         5 my $val = pop;
272              
273 3         10 my @dims = $self->dims;
274 3         7 my $n = $dims[0];
275              
276 3         10 for (my $i=0;$i<$n;$i++) {
277 9 100       31 my $chr = ($i >= length($val)) ? 0 : unpack ("C", substr ($val, $i, 1));
278 9         53 PDL::Core::set_c ($self, [$i, @_], $chr);
279             }
280            
281             }
282              
283             =head2 atstr
284              
285             =for ref
286              
287             Function to fetch one string value from a PDL::Char type PDL, given a position within the PDL.
288             The input position of the string, not a character in the string. The length of the input
289             string is the implied first dimension.
290              
291             =for usage
292              
293             $char = PDL::Char->new( [['abc', 'def', 'ghi'], ['jkl', 'mno', 'pqr']] );
294             print $char->atstr(0,1);
295             # Prints:
296             # jkl
297              
298             =cut
299              
300             sub atstr { # Fetchs a string value from a PDL::Char
301 3 50   3 1 10 PDL::Core::barf('Usage: atstr($pdl, $x, $y,..,)') if (@_ < 2);
302 3         7 my $self = shift;
303            
304 3         7 my $str = ':,' . join (',', map {"($_)"} @_);
  9         26  
305 3         12 my $w = $self->slice($str);
306            
307 3         16 my $val = ${$w->get_dataref}; # get the data
  3         18  
308 3         11 $val =~ s/\00+$//g; # get rid of any null padding
309 3         42 return $val;
310             }
311              
312             # yuck ;) this is a cool little accessor method
313             # rebless a slice into PDL; originally
314             # Marc's idea used in PDL::Complex
315             sub numeric {
316 0     0 0   my ($seq) = @_;
317 0           return bless $seq->slice(''), 'PDL';
318             }
319              
320             1;