File Coverage

blib/lib/PDLA/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

package PDLA::Char;

@ISA = qw (PDLA);
use overload ("\"\""   =>  \&PDLA::Char::string);
use strict;
use vars ('$level', '@dims'); # Global Vars used


=head1 NAME

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

=head1 SYNOPSIS

 use PDLA;
 use PDLA::Char;

 my $pchar = PDLA::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 PDLA allows one to manipulate PDLAs 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 charactar 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
PDLA::NetCDF module.

=head1 FUNCTIONS

=head2 new

=for ref

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

=for usage

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

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

=for example

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

=cut


sub new {
  my $type = shift;
  my $value = (scalar(@_)>1 ? [@_] : shift);  # ref thyself

  # re-bless byte PDLAs as PDLA::Char
  if (ref($value) =~ /PDLA/) {
    PDLA::Core::barf('Cannot convert a non-byte PDLA to PDLA::Char')
      if ($value->get_datatype != $PDLA::Types::PDLA_B);
    return bless $value, $type;
  }

  my $ptype = $PDLA::Types::PDLA_B;
  my $self  = PDLA->initialize();
  $self->set_datatype($ptype);
  $value = 0 if !defined($value);
  $level = 0; @dims = (); # package vars
  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 $str = _rcharpack($value,\$maxlength,\$samelen);
  unless( $samelen){  # Strings weren't the same length, go thru again and null pad to
	      	     # the max length.
	$str = _rcharpack2($value,$maxlength);
  }
  $self->setdims([reverse @dims]);
  ${$self->get_dataref} = $str;
  $self->upd_data();
  return bless $self, $type;
}

# Take an N-D perl array of strings and pack it into a single string,
# updating the $level and @dims package vars on the way.
# 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) = @_; # reference to $maxlength, $samelen

  my ($ret,$type);

  $ret = "";
  if (ref($w) eq "ARRAY") {

    PDLA::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) {
      PDLA::Core::barf('Array is not rectangular') unless $type eq ref($_); # Equal types
      $ret .= _rcharpack($_,$maxlenref, $samelenref);
    }

    $level--;

  }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{
    PDLA::Core::barf("Don't know how to make a PDLA 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) = @_; 		  # 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--;

  }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 PDLA (created by 'char') in a pretty format.

=for usage

 $char = PDLA::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 = $PDLA::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 PDLA.  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 PDLA.  It will be truncated if it is longer.

=for usage

 $char = PDLA::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.
  PDLA::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));
    PDLA::Core::set_c ($self, [$i, @_], $chr);
  }

}

=head2 atstr

=for ref

Function to fetch one string value from a PDLA::Char type PDLA, given a position within the PDLA.
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 = PDLA::Char->new( [['abc', 'def', 'ghi'], ['jkl', 'mno', 'pqr']] );
 print $char->atstr(0,1);
 # Prints:
 # jkl

=cut

sub atstr {    # Fetchs a string value from a PDLA::Char
  PDLA::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 PDLA; originally
# Marc's idea used in PDLA::Complex
sub numeric {
  my ($seq) = @_;
  return bless $seq->slice(''), 'PDLA';
}

1;