File Coverage

blib/lib/PDL/Char.pm

Criterion	Covered	Total	%
statement	93	96	96.8
branch	29	38	76.3
condition	9	11	81.8
subroutine	10	11	90.9
pod	4	5	80.0
total	145	161	90.0

package PDL::Char;

use strict;
use warnings;
our @ISA = qw (PDL);
use overload '""' => \&PDL::Char::string;

sub import {} # override the PDL one to avoid the big import list

=head1 NAME

PDL::Char -- PDL subclass which allows reading and writing of fixed-length character strings as byte PDLs

=head1 SYNOPSIS

 use PDL;
 use PDL::Char;

 my $pchar = PDL::Char->new( [['abc', 'def', 'ghi'],['jkl', 'mno', 'pqr']] );

 $pchar->setstr(1,0,'foo');

 print $pchar; # 'string' bound to "", perl stringify function
 # Prints:
 # [
 #  ['abc' 'foo' 'ghi']
 #  ['jkl' 'mno' 'pqr']
 # ]

 print $pchar->atstr(2,0);
 # Prints:
 # ghi

=head1 DESCRIPTION

This subclass of PDL allows one to manipulate PDLs of 'byte' type as if they were made of fixed
length strings, not just numbers.

This type of behavior is useful when you want to work with character grids.  The indexing is done
on a string level and not a character level for the 'setstr' and 'atstr' commands.

This module is in particular useful for writing NetCDF files that include character data using the
L module.

=head1 FUNCTIONS

=head2 new

=for ref

Function to create a byte PDL from a string, list of strings, list of list of strings, etc.

=for usage

 # create a new PDL::Char from a perl array of strings
 $strpdl = PDL::Char->new( ['abc', 'def', 'ghij'] );

 # Convert a PDL of type 'byte' to a PDL::Char
 $strpdl1 = PDL::Char->new (sequence (byte, 4, 5)+99);

=for example

 $pdlchar3d = PDL::Char->new([['abc','def','ghi'],['jkl', 'mno', 'pqr']]);

=cut

sub new {
  my $type = shift;
  my $value = (scalar(@_)>1 ? [@_] : shift);  # ref thyself
  # re-bless byte PDLs as PDL::Char
  if (ref($value) =~ /PDL/) {
    PDL::Core::barf('Cannot convert a non-byte PDL to PDL::Char')
      if ($value->get_datatype != $PDL::Types::PDL_B);
    return bless $value, $type;
  }
  my $ptype = $PDL::Types::PDL_B;
  my $self  = PDL->initialize();
  $self->set_datatype($ptype);
  $value = 0 if !defined($value);
  my $maxlength;      # max length seen for all character strings
  my $samelen	= 1;  # Flag = 1 if all character strings are the same length
  # 1st Pass thru the perl array structure, assume all strings the same length
  my @dims;
  my $str = _rcharpack($value,\$maxlength,\$samelen,0,\@dims);
  unless( $samelen){  # Strings weren't the same length, go thru again and null pad to
	      	     # the max length.
	$str = _rcharpack2($value,$maxlength,0,\@dims);
  }
  $self->setdims([reverse @dims]);
  $self->update_data_from($str);
  return bless $self, $type;
}

# Take an N-D perl array of strings and pack it into a single string,
# Used by the 'char' constructor
#
#  References supplied so $maxlength and $samelen are updated along the way as well.
#
#
#   This version (_rcharpack) is for the 1st pass thru the N-d string array.
#    It assumes that all strings are the same length, but also checks to see if they aren't
sub _rcharpack {
  my $w = shift;		     # Input string
  my ($maxlenref, $samelenref, $level, $dims) = @_; # reference to $maxlength, $samelen
  my ($ret,$type);
  $ret = "";
  if (ref($w) eq "ARRAY") {
    PDL::Core::barf('Array is not rectangular') if (defined($dims->[$level]) and
					$dims->[$level] != scalar(@$w));
    $dims->[$level] = scalar (@$w);
    $level++;
    $type = ref($$w[0]);
    for(@$w) {
      PDL::Core::barf('Array is not rectangular') unless $type eq ref($_); # Equal types
      $ret .= _rcharpack($_,$maxlenref, $samelenref, $level, $dims);
    }
  }elsif (ref(\$w) eq "SCALAR") {
    my $len = length($w);
    # Check for this length being different then the others:
    $$samelenref = 0 if( defined($$maxlenref) && ($len != $$maxlenref) );
    # Save the max length:
    $$maxlenref = $len if( !defined($$maxlenref) || $len > $$maxlenref); # see if this is the max length seen so far
    $dims->[$level] = $len;
    $ret = $w;
  }else{
    PDL::Core::barf("Don't know how to make a PDL object from passed argument");
  }
  return $ret;
}

#   This version (_rcharpack2) is for the 2nd pass (if required) thru the N-d string array.
#   If the 1st pass thru (_rcharpack) finds that all strings were not the same length,
#   this routine will go thru and null-pad all strings to the max length seen.
#     Note: For efficiency, the error checking is not repeated here, because any errors will
#       already be detected in the 1st pass.
#
sub _rcharpack2 {
  my $w = shift;		  # Input string
  my ($maxlen, $level, $dims) = @_; 		  # Length to pad strings to
  my ($ret,$type);
  $ret = "";
  if (ref($w) eq "ARRAY") {
    #  Checks not needed the second time thru (removed)
    $dims->[$level] = scalar (@$w);
    $level++;
    $type = ref($$w[0]);
    for(@$w) {
      $ret .= _rcharpack2($_,$maxlen,$level,$dims);
    }
  }elsif (ref(\$w) eq "SCALAR") {
    my $len = length($w);
    $dims->[$level] = $maxlen;
    $ret = $w.("\00" x ($maxlen - $len));
  }
  return $ret;
}

=head2 string

=for ref

Function to print a character PDL (created by 'char') in a pretty format.

=for usage

 $char = PDL::Char->new( [['abc', 'def', 'ghi'], ['jkl', 'mno', 'pqr']] );
 print $char; # 'string' bound to "", perl stringify function
 # Prints:
 # [
 #  ['abc' 'def' 'ghi']
 #  ['jkl' 'mno' 'pqr']
 # ]

 # 'string' is overloaded to the "" operator, so:
 # print $char;
 # should have the same effect.

=cut

sub string {
  my $self   = shift;
  my $level  = shift || 0;
  my $sep = $PDL::use_commas ? "," : " ";
  if ($self->dims == 1) {
    my $str = ${$self->get_dataref}; # get copy of string
    $str =~ s/\00+$//g; # get rid of any null padding
    return "\'". $str. "\'". $sep;
  } else {
    my @dims = reverse $self->dims;
    my $ret = '';
    $ret .= (" " x $level) . '[' . ((@dims == 2) ? ' ' : "\n");
    for (my $i=0;$i<$dims[0];$i++) {
      my $slicestr = ":," x (scalar(@dims)-1) . "($i)";
      my $substr = $self->slice($slicestr);
      $ret .= $substr->string($level+1);
    }
    $ret .= (" " x $level) . ']' . $sep . "\n";
    return $ret;
  }
}

=head2 setstr

=for ref

Function to set one string value in a character PDL.  The input position is
the position of the string, not a character in the string.  The first dimension
is assumed to be the length of the string.

The input string will be null-padded if the string is shorter than the first
dimension of the PDL.  It will be truncated if it is longer.

=for usage

 $char = PDL::Char->new( [['abc', 'def', 'ghi'], ['jkl', 'mno', 'pqr']] );
 $char->setstr(0,1, 'foobar');
 print $char; # 'string' bound to "", perl stringify function
 # Prints:
 # [
 #  ['abc' 'def' 'ghi']
 #  ['foo' 'mno' 'pqr']
 # ]
 $char->setstr(2,1, 'f');
 print $char; # 'string' bound to "", perl stringify function
 # Prints:
 # [
 #  ['abc' 'def' 'ghi']
 #  ['foo' 'mno' 'f']      -> note that this 'f' is stored "f\0\0"
 # ]

=cut

sub setstr {    # Sets a particular single value to a string.
  PDL::Core::barf('Usage: setstr($pdl, $x, $y,.., $value)') if $#_<2;
  my $self = shift;
  my $val  = pop;
  my @dims = $self->dims;
  my $n    = $dims[0];
  for (my $i=0;$i<$n;$i++) {
    my $chr = ($i >= length($val)) ? 0 : unpack ("C", substr ($val, $i, 1));
    PDL::Core::set_c ($self, [$i, @_], $chr);
  }
}

=head2 atstr

=for ref

Function to fetch one string value from a PDL::Char type PDL, given a position within the PDL.
The input position of the string, not a character in the string.  The length of the input
string is the implied first dimension.

=for usage

 $char = PDL::Char->new( [['abc', 'def', 'ghi'], ['jkl', 'mno', 'pqr']] );
 print $char->atstr(0,1);
 # Prints:
 # jkl

=cut

sub atstr {    # Fetchs a string value from a PDL::Char
  PDL::Core::barf('Usage: atstr($pdl, $x, $y,..,)') if (@_ < 2);
  my $self = shift;
  my $str = ':,' . join (',', map {"($_)"} @_);
  my $w = $self->slice($str);
  my $val = ${$w->get_dataref}; # get the data
  $val =~ s/\00+$//g; # get rid of any null padding
  return $val;
}

# yuck ;) this is a cool little accessor method
# rebless a slice into PDL; originally
# Marc's idea used in PDL::Complex
sub numeric {
  my ($seq) = @_;
  return bless $seq->slice(''), 'PDL';
}

1;