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   467 use overload ("\"\"" => \&PDL::Char::string);
  1         3  
  1         7  
5 1     1   63 use strict;
  1         1  
  1         25  
6 1     1   4 use vars ('$level', '@dims'); # Global Vars used
  1         2  
  1         1309  
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 693 my $type = shift;
69 3 50       12 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       10 PDL::Core::barf('Cannot convert a non-byte PDL to PDL::Char')
74             if ($value->get_datatype != $PDL::Types::PDL_B);
75 1         4 return bless $value, $type;
76             }
77              
78 2         4 my $ptype = $PDL::Types::PDL_B;
79 2         61 my $self = PDL->initialize();
80 2         30 $self->set_datatype($ptype);
81 2 50       8 $value = 0 if !defined($value);
82 2         5 $level = 0; @dims = (); # package vars
  2         4  
83 2         4 my $maxlength; # max length seen for all character strings
84 2         5 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         8 my $str = _rcharpack($value,\$maxlength,\$samelen);
88 2 100       9 unless( $samelen){ # Strings weren't the same length, go thru again and null pad to
89             # the max length.
90 1         7 $str = _rcharpack2($value,$maxlength);
91             }
92 2         16 $self->setdims([reverse @dims]);
93 2         5 ${$self->get_dataref} = $str;
  2         11  
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   36 my $w = shift; # Input string
110 28         44 my ($maxlenref, $samelenref) = @_; # reference to $maxlength, $samelen
111              
112 28         33 my ($ret,$type);
113            
114 28         37 $ret = "";
115 28 100       55 if (ref($w) eq "ARRAY") {
    50          
116              
117 10 50 66     29 PDL::Core::barf('Array is not rectangular') if (defined($dims[$level]) and
118             $dims[$level] != scalar(@$w));
119 10         15 $dims[$level] = scalar (@$w);
120 10         12 $level++;
121            
122 10         16 $type = ref($$w[0]);
123 10         17 for(@$w) {
124 26 50       48 PDL::Core::barf('Array is not rectangular') unless $type eq ref($_); # Equal types
125 26         43 $ret .= _rcharpack($_,$maxlenref, $samelenref);
126             }
127            
128 10         14 $level--;
129            
130             }elsif (ref(\$w) eq "SCALAR") {
131 18         25 my $len = length($w);
132              
133             # Check for this length being different then the others:
134 18 100 100     55 $$samelenref = 0 if( defined($$maxlenref) && ($len != $$maxlenref) );
135             # Save the max length:
136 18 100 66     53 $$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         28 $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         62 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   10 my $w = shift; # Input string
157 9         16 my ($maxlen) = @_; # Length to pad strings to
158              
159 9         11 my ($ret,$type);
160            
161 9         13 $ret = "";
162 9 100       22 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         5 $level++;
168            
169 3         4 $type = ref($$w[0]);
170 3         6 for(@$w) {
171 8         17 $ret .= _rcharpack2($_,$maxlen);
172             }
173            
174 3         5 $level--;
175            
176             }elsif (ref(\$w) eq "SCALAR") {
177 6         7 my $len = length($w);
178              
179 6         7 $dims[$level] = $maxlen;
180 6         14 $ret = $w.("\00" x ($maxlen - $len));
181             }
182 9         20 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 91 my $self = shift;
213 34   100     73 my $level = shift || 0;
214              
215 34 50       62 my $sep = $PDL::use_commas ? "," : " ";
216              
217 34 100       75 if ($self->dims == 1) {
218 23         31 my $str = ${$self->get_dataref}; # get copy of string
  23         103  
219 23         59 $str =~ s/\00+$//g; # get rid of any null padding
220 23         192 return "\'". $str. "\'". $sep;
221             } else {
222 11         25 my @dims = reverse $self->dims;
223 11         17 my $ret = '';
224 11 100       34 $ret .= (" " x $level) . '[' . ((@dims == 2) ? ' ' : "\n");
225 11         28 for (my $i=0;$i<$dims[0];$i++) {
226 31         118 my $slicestr = ":," x (scalar(@dims)-1) . "($i)";
227 31         76 my $substr = $self->slice($slicestr);
228 31         85 $ret .= $substr->string($level+1);
229             }
230 11         31 $ret .= (" " x $level) . ']' . $sep . "\n";
231 11         57 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 802 PDL::Core::barf('Usage: setstr($pdl, $x, $y,.., $value)') if $#_<2;
270 3         8 my $self = shift;
271 3         6 my $val = pop;
272              
273 3         10 my @dims = $self->dims;
274 3         6 my $n = $dims[0];
275              
276 3         9 for (my $i=0;$i<$n;$i++) {
277 9 100       33 my $chr = ($i >= length($val)) ? 0 : unpack ("C", substr ($val, $i, 1));
278 9         59 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 11 PDL::Core::barf('Usage: atstr($pdl, $x, $y,..,)') if (@_ < 2);
302 3         6 my $self = shift;
303            
304 3         7 my $str = ':,' . join (',', map {"($_)"} @_);
  9         27  
305 3         10 my $w = $self->slice($str);
306            
307 3         7 my $val = ${$w->get_dataref}; # get the data
  3         19  
308 3         13 $val =~ s/\00+$//g; # get rid of any null padding
309 3         29 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;