File Coverage

blib/lib/Data/Secs2.pm

Criterion	Covered	Total	%
statement	52	548	9.4
branch	1	338	0.3
condition	0	99	0.0
subroutine	17	27	62.9
pod	11	11	100.0
total	81	1023	7.9

#!perl
#
# Documentation, copyright and license is at the end of this file.
#
package  Data::Secs2;

use 5.001;
use strict;
use warnings;
use warnings::register;
use attributes;

use vars qw($VERSION $DATE $FILE);
$VERSION = '1.25';
$DATE = '2004/05/20';
$FILE = __FILE__;

use Data::Startup 0.02;
use Data::Str2Num 0.05;
use Data::Dumper;
$Data::Dumper::Sortkeys = 1; # dump hashes sorted
$Data::Dumper::Terse = 1; # avoid Varn Variables

use vars qw(@ISA @EXPORT_OK $default_options);
require Exporter;
@ISA=qw(Exporter Data::Startup);
@EXPORT_OK = qw(arrayify config listify neuterify numberify perlify
                perl_typify secsify secs_elementify stringify textify
                transify);

$default_options = new Data::Secs2;

#######
# Object used to set default, startup, options values.
#
sub new
{
   my $class = shift;
   $class = ref($class) if ref($class);
   my $self = $class->Data::Startup::new(
       die => 0,
       add_obj_format_code => 0,
       obj_format_code => '',
       type => 'ascii',
       scalar => 0,
       spaces => '  ',
       indent => '',
       version => $VERSION,
       warnings => 0,
   );
   $self->Data::Startup::override(@_);

}


######
# WARNING: For some unknow reason that needs investigation
# the use of SelfLoader causes massive failures, particular
# in the regards to interface with SecsPack
#
# use SelfLoader;
# 1
# __DATA__


###########
# The keys for hashes are not sorted. In order to
# establish a canonical form for the  hash, sort
# the hash and convert it to an array with a two
# leading control elements in the array.
#
# The elements determine if the data is an array
# or a hash and its reference.
#
sub arrayify
{
     ######
     # This subroutine uses no object data; therefore,
     # drop any class or object.
     #
     my $event;
     shift if UNIVERSAL::isa($_[0],__PACKAGE__);

     my ($var) = shift @_;

     $default_options = Data::Secs2->new() unless $default_options;
     my $options = $default_options->override(@_);

     my $class = ref($var);
     return $var unless $class;

     my $reftype = attributes::reftype($var);
     $class = $class ne $reftype ? $class : '';
     my @array = ($class,$reftype);

     #####
     # Add rest of the members to the canoncial array
     # based on underlying data type
     #
     if ( $reftype eq 'HASH') {
         foreach (sort keys %$var ) {
             push @array, ($_, $var->{$_});
         }
     }
     elsif($reftype eq 'ARRAY') {
         push @array, @$var;
     }
     elsif($reftype eq 'SCALAR') {
         push @array, $$var;
     }
     elsif($reftype eq 'REF') {
         push @array, $var;
     }
     elsif($reftype eq 'CODE') {
         push @array, $var;
     }
     elsif($reftype eq 'GLOB') {
         push @array,(*$var{SCALAR},*$var{ARRAY},*$var{HASH},*$var{CODE},
                          *$var{IO},*$var{NAME},*$var{PACKAGE},"*$var"),
     }
     else {
         $event = "Unknown underlying data type\n";
         @array = '';
         goto EVENT;
     }
     return \@array;

EVENT:
    $event .= "\tData::Secs2::arrayify $VERSION\n";
    if($options->{warnings} ) {
        warn($event);
    }
    elsif($options->{die}) {
        die($event);
    }
    $event;
}


######
# Program module wide configuration
#
sub config
{
     $default_options = Data::Secs2->new() unless $default_options;
     my $self = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift :  $default_options;
     $self = ref($self) ? $self : $default_options;
     $self->Data::Startup::config(@_);

}


#######
#
#
my %format = (
  L  =>  0x00, #  List (length in elements)
  B  =>  0x20, #  Binary
  T  =>  0x24, #  Boolean
  A  =>  0x40, #  ASCII
  J  =>  0x44, #  JIS-8
 S8  =>  0x60, #  8-byte integer (unsigned)
 S1  =>  0x62, #  1-byte integer (unsigned)
 S2  =>  0x64, #  2-byte integer (unsigned)
 S4  =>  0x70, #  4-byte integer (unsigned)
 F8  =>  0x80, #  8-byte floating
 F4  =>  0x90, #  4-byte floating
 U8  =>  0xA0, #  8-byte integer (unsigned)
 U1  =>  0xA4, #  1-byte integer (unsigned)
 U2  =>  0xA8, #  2-byte integer (unsigned)
 U4  =>  0xB0, #  4-byte integer (unsigned)
);




################
# This subroutine walks a nested data structure, and listify each level
# into a perlified SECII message. The assumption is that the nested
# data structure consists of only references to Perl arrays,
#
sub listify
{

     ######
     # This subroutine uses no object data; therefore,
     # drop any class or object.
     #
     $default_options = Data::Secs2->new() unless $default_options;
     my $self = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift :  $default_options;
     $self = ref($self) ? $self : $default_options;
     my %options = %$self; # try not to mangle or bless the default options

     #########
     # Return an array, so going to walk the array, looking
     # for hash and array references to arrayify
     #
     # Use a stack for the walk instead of recursing. Easier
     # to maintain when the data is on a separate stack instead
     # of the call (return) stack and only the pertient data
     # is stored on the separate stack. The return stack does
     # not grow. Instead the separate recurse stack grows.
     #
     my %dups = ();
     my @vars = ();
     my @index = ();

     #####
     # Perl format code
     my @secs_obj = ('U1',[80]);
     my $i = 0;
     my @var = @_; # do not clobber @_ so make a copy
     my $var = \@var;
     my ($is_numeric,$format,$num,$ref,$ref_dup,@dup_index,$str);

     for(;;) {

        while($i < @$var) {

             ######
             # Index to the same reference structure in the nested data.
             # First number is the number of indices. The indices are
             # within each level of the nested listes.
             #
             $ref_dup = (ref($var->[$i])) ? "$var->[$i]"  : '';
             if( $dups{$ref_dup} ) {
                 push @secs_obj, ('L', '3', 'A', '', 'A', 'Index', 'N', $dups{$ref_dup});
                 $i++;
                 next;
             }


             #####
             # Try to convert to a pack numeric array.
             if (ref($var->[$i]) eq 'ARRAY') {

                 #####
                 # Quit very coarse filter that eliminates many numerics
                 #
                 $is_numeric = 1;
                 foreach (@{$var->[$i]}) {
                     if (ref($_) && ref($_) ne 'ARRAY') {
                        $is_numeric = 0;
                        last;
                     }
                     unless (defined $_ && $_ =~ /\s*\S+\s*/ ) {
                        $is_numeric = 0;
                        last;
                     }
                 }
                 if($is_numeric) {
                     ($str, my @num) = Data::Str2Num->str2float(@{$var->[$i]}, {ascii_float => 1});
                     if(@num != 0 && @$str == 0) {
                         push @secs_obj, 'N', \@num;
                         $i++;
                         next;
                     }
                 }
             }

             $var->[$i] = arrayify( $var->[$i] );
             $ref = ref($var->[$i]);

             ####
             # If $var->[$i] is a reference it is a reference to an array of
             # an underlying data type or object that is arrayified.
             #
             if ($ref) {

                 $dups{$ref_dup} = (scalar @secs_obj); # element in @secs_obj

                 ########
                 # Nest for an 'ARRAY' reference to the arrayified the refereceddata
                 #
                 # The listify subroutine uses @vars stacks to nest. When listify finds
                 # member of the current array that is a reference to another array,
                 # listify stops working on the current array. It save the position
                 # that it stop working by pushing a refenrence to the current array
                 # and the position (index), $i of the array reference onto the @vars
                 # stack. Listify will then start working on the new array. When all work
                 # on the new array is listify will pop the old $var array reference
                 # and array index $i off of the @vars stack and continue work on the
                 # old array.
                 #
                 if($ref eq 'ARRAY' ) {

                     ####
                     # Save info so listify can resume work on the old array
                     #
                     push @vars, ($var,$i+1);

                     ####
                     # Start work on the new array
                     #
                     $var = $var->[$i];
                     $i = 0;

                     #####
                     # Output a List element whose body is the number of
                     # members in the new array that listify is starting
                     # to work on.
                     #
                     push @secs_obj, ('L', scalar @$var);
                     next;
                 }
             }

             ########
             # Otherwise, a pure simple scalar
             #
             else {

                 #####
                 # An undefined is translated to SECSII data structure as L[0]
                 #
                 if(defined $var->[$i]) {

                     ######
                     # Try for a single packed number type
                     #
                     ($str,my @num) = Data::Str2Num->str2float($var->[$i], {ascii_float => 1});
                     if(@num == 1 && @$str == 0) {
                         push @secs_obj, 'N', $num[0];
                     }

                     #####
                     # Else ascii
                     else {
                         push @secs_obj, 'A', $var->[$i];
                     }
                 }
                 else {
                     push @secs_obj, 'L', 0;
                 }

             }
             $i++;
         }

         #####
         # At the end of the current array, so go back
         # working on any array whose work was interupted
         # to work on the current array.
         #
         last unless @vars;
         ($var,$i) = splice( @vars, -2, 2);

     }

     ########
     # Listified unpacked SECSII message
     #
     \@secs_obj;

}


#######
#
#
my @bin_format = (
  'L',   #  0 List (length in elements)
   '',   #  1
   '',   #  2
   '',   #  3
   '',   #  4
   '',   #  5
   '',   #  6
   '',   #  7
  'B',   #  8 Binary
  'T',   #  9 Boolean
   '',   # 10
   '',   # 11
   '',   # 12
   '',   # 13
   '',   # 14
   '',   # 15
  'A',   # 16 ASCII
  'J',   # 17 JIS-8
   '',   # 18
   '',   # 19
   '',   # 20
   '',   # 21
   '',   # 22
   '',   # 23
 'S8',   # 24 8-byte integer (unsigned)
 'S1',   # 25 1-byte integer (unsigned)
 'S2',   # 26 2-byte integer (unsigned)
   '',   # 27
 'S4',   # 28 4-byte integer (unsigned)
   '',   # 29
   '',   # 30
   '',   # 31
 'F8',   # 32 8-byte floating
   '',   # 33
   '',   # 34
   '',   # 35
 'F4',   # 36 4-byte floating
   '',   # 37
   '',   # 38
   '',   # 39
 'U8',   # 40 8-byte integer (unsigned)
 'U1',   # 41 1-byte integer (unsigned)
 'U2',   # 42 2-byte integer (unsigned)
   '',   # 43
 'U4',   # 44 4-byte integer (unsigned)
   '',   # 45
   '',   # 46
   '',   # 47
   '',   # 48
   '',   # 49
   '',   # 50
   '',   # 51
   '',   # 52
   '',   # 53
   '',   # 54
   '',   # 55
   '',   # 56
   '',   # 57
   '',   # 58
   '',   # 59
   '',   # 60
   '',   # 61
   '',   # 63
);



####
#
#
sub neuterify
{
     require Data::SecsPack;

     ######
     # This subroutine uses no object data; therefore,
     # drop any class or object.
     #
     my $event;
     shift if UNIVERSAL::isa($_[0],__PACKAGE__);

     my $binary_secs = shift;

     $default_options = Data::Secs2->new() unless $default_options;
     my $options = $default_options->override(@_);

     my @secs_format_element = unpack('C3',$binary_secs);
     my @secs_obj = ();

     #####
     # Data format code S - Secsii  P - Perl
     my $obj_format_code = $options->{obj_format_code} if defined $options->{obj_format_code};
     if( $options->{$obj_format_code} ) {
         if(!$options->{add_obj_format_code} && $secs_format_element[0] == 165
               && $secs_format_element[1] == 1 &&
               ($secs_format_element[2] == 80 || $secs_format_element[2] == 83)  ) {
             substr($binary_secs,2,1) = $options->{$obj_format_code};
         }
         else {
             @secs_obj = ('U1',[unpack 'C1',$options->{obj_format_code}]);
         }
     }

     use integer;
     my ($format, $bytes_per_cell, $length_size, $length, $length_num, $number);
     while($binary_secs) {

          #####
          # Decode format byte
          $format = unpack('C1',$binary_secs);
          $binary_secs = substr($binary_secs,1);
          $length_size = $format & 0x03;
          $format = $bin_format[($format & 0xFC) >> 2];
          unless($format) {
             $event = "Unknown SECSII format, $format\n";
             goto EVENT;
          }
          push @secs_obj,$format;

          ######
          # SEMI E5-94, 6.2.1, 6.3.1.
          #   A zero-length in the format byte is illegal and produces an error.
          #
          # The scalar option allows for A non-compliant SEMI E5-94 where a
          # a zero-length in the format byte signals a single cell scalar follows.
          #
          if($length_size == 0 ) {
              if( $options->{scalar} && $format ne 'L') {
                  $bytes_per_cell = $format =~ /(\d)$/ ? $1 : 1;
                  if( $format =~  /[SUF]\d/ || $format eq 'T') {
                       $number = Data::SecsPack->unpack_num( $format,
                                    substr($binary_secs,0,$bytes_per_cell),
                                    $options->{'Data::SecsPack'});
                       unless(ref($number) eq 'ARRAY') {
                           $event =  $number;
                           goto EVENT;
                       }
                       if(@$number != 1) {
                           $event = 'Number ' . (join ' ',@$number) . "not a scalar\n" ;
                           goto EVENT;
                       }
                       push @secs_obj,$number->[0];
                  }
                  else {
                      push @secs_obj,substr($binary_secs,0,$bytes_per_cell);
                  }
                  $binary_secs = substr($binary_secs,$bytes_per_cell);
                  next;
              }
              else {
                  $event = "Format byte length size field is zero.\n";
                  goto EVENT;
              }
          }

          #####
          # decode number of elements
          $length = substr($binary_secs,0,$length_size);
          $binary_secs = substr($binary_secs,$length_size);
          $length_num = Data::SecsPack->unpack_num('U1', $length, $options->{'Data::SecsPack'});
          unless(ref($length_num) eq 'ARRAY') {
             $event = "Bad length\n";
             goto EVENT;
          }
          $length_num = ${$length_num}[0];

          ######
          # Grab the elements
          if($format eq 'L') {
              push @secs_obj,$length_num;
          }
          elsif($length_num) {
              if( $format =~  /[SUF]\d/ || $format eq 'T') {
                  $number = Data::SecsPack->unpack_num( $format,
                              substr($binary_secs,0,$length_num), $options->{'Data::SecsPack'});
                  unless (ref($number) eq 'ARRAY') {
                      $event = $number;
                      goto EVENT;
                  }
                  push @secs_obj,$number;
              }
              else {
                  push @secs_obj,substr($binary_secs,0,$length_num);
              }
              $binary_secs = substr($binary_secs,$length_num);
          }
          else {
              push @secs_obj,'';
          }
     }
     no integer;
     return \@secs_obj;

EVENT:
    $event .= "\tData::Secs2::neuterify $VERSION\n";
    if($options->{warnings} ) {
        warn($event);
    }
    elsif($options->{die}) {
        die($event);
    }
    $event;
}


#####
#
#
sub perlify
{
     ######
     # This subroutine uses no object data; therefore,
     # drop any class or object.
     #
     my $event;
     shift if UNIVERSAL::isa($_[0],__PACKAGE__);

     ########
     # Listified unpacked SECSII message
     #
     my $secs_obj = shift @_;

     $default_options = Data::Secs2->new() unless $default_options;
     my $options = $default_options->override(@_);

     my @nested_stack = ();

     my ($head, $body);
     my ($class, $type);

     #####
     # Establish root array with a count that goes on
     # until the $secs_obj is exhasted.
     #
     my $new_var_p;
     my $count = -1;
     my @root_array = ('','ARRAY');
     my $nested_var_p = \@root_array;
     my (%dup,$position);

     $head = $secs_obj->[0];
     $body = $secs_obj->[1];
     unless ($head eq 'U1' && ref($body) eq 'ARRAY' && @$body == 1 && $$body[0] eq '80') {
         $event = "Not a Perl SECS object\n";
         goto EVENT;
     }

     my $i = 2;
     while($i < @{$secs_obj} ) {

         $head = $secs_obj->[$i++];
         $body = $secs_obj->[$i++];
         if( $head eq 'L') {

             if($body == 0) {
                push @$nested_var_p, undef;
                $count--;
             }
             else {
                 if ('A' ne $secs_obj->[$i++]) {
                     $event = "Wrong format for Perl reference class, $secs_obj->[$i-1]\n" ;
                     goto EVENT;
                 }
                 $class = $secs_obj->[$i++];
                 if ('A' ne $secs_obj->[$i++]) {
                     $event = "Wrong format type for Perl reference underlying data type, $secs_obj->[$i-1]\n";
                     goto EVENT;
                 }
                 $type = $secs_obj->[$i++];
                 unless ($i < @{$secs_obj}) {
                     $event = "No body for Perl reference.\n" ;
                     goto EVENT;
                 }
                 if( $class eq '' && $type eq 'Index') {
                     $head = $secs_obj->[$i++];
                     unless($head =~ /^[UN]/) {
                         $event = "Perl index item has wrong format code, $head \n";
                         goto EVENT;
                     }
                     $body = $secs_obj->[$i++];
                     if(ref($body) eq 'ARRAY') {
                         unless (@$body == 1) {
                             $event = "Perl Index body must have only one cell\n";
                             goto EVENT;
                         }
                         $body = $body->[0];
                     }
                     $new_var_p = $dup{$body};
                     push @$nested_var_p, $new_var_p;
                     $count--;
                 }
                 else {

                     #######
                     # The position $i - 6 is the index into @secs_obj of the
                     # element $head 'L'. This is the position that appears in
                     # Perl 'L', 3, 'A', '','A','Index',U1, $position Index
                     # list element.
                     #
                     $new_var_p = [$class,$type];
                     push @nested_stack,$nested_var_p, $count-1, $i - 6;
                     $nested_var_p = $new_var_p;
                     $count = $body-2;
                 }
             }
         }
         elsif( $head =~ /^[AJBFNSTU]/ ) {
             push @$nested_var_p,$body;
             $count--;
         }
         else {
             $event = "Unknown format type, $head\n";
             goto EVENT;
         }

         #####
         # At the end of the current array, so go back
         # working on any array whose work was interupted
         # to work on the current array.
         #
         while(@nested_stack && $count <= 0) {
             last unless $count == 0;
             $new_var_p = perl_typify($nested_var_p);
             ($nested_var_p, $count, $position) = splice(@nested_stack,-3,3);
             push @$nested_var_p, $new_var_p;
             $dup{$position} = $new_var_p;
         }
     }
     $nested_var_p = perl_typify($nested_var_p);
     return $nested_var_p;

EVENT:
    $event .= "\tData::Secs2::perlify $VERSION\n";
    if($options->{warnings} ) {
        warn($event);
    }
    elsif($options->{die}) {
        die($event);
    }
    $event;
}


######
#
#
sub perl_typify
{
     shift if UNIVERSAL::isa($_[0],__PACKAGE__);

     my $event;
     my ($array) = (@_);

     $default_options = Data::Secs2->new() unless $default_options;
     my $options = $default_options->override(@_);

     my @array = @$array;
     my $class = shift @array;
     my $reftype = shift @array;
     my $ref;

     #####
     # Add rest of the members to the canoncial array
     # based on underlying data type
     #
     if ( $reftype eq 'HASH') {
         $ref = {@array};
     }
     elsif($reftype eq 'ARRAY') {
         $ref = \@array;
     }
     elsif($reftype eq 'SCALAR') {
         unless( @array == 1) {
             $event = "Bad scalar body\n";
             goto EVENT;
         }
         $ref = \$array[0];
     }
     elsif($reftype eq 'REF') {
         unless( @array == 1) {
             $event =  "Bad ref body\n";
             goto EVENT;
         }
         $ref = $array[0];
     }
     elsif($reftype eq 'CODE') {
          unless( @array == 1) {
             $event = "Bad code body.\n";
             goto EVENT;
         }
         $ref = $array[0];
     }
     elsif($reftype eq 'GLOB') {
         unless(@array == 8) {
             $event =  "Bad glob body\n";
             goto EVENT;
         }
         $ref = \@array;
     }
     else {
         $event = "Unknown underlying data type, $reftype\n";
         goto EVENT;
     }
     $ref = bless $ref,$class if($class);
     return($ref);

EVENT:
    $event .= "\tData::Secs2::perl_typify $VERSION\n";
    if($options->{warnings} ) {
        warn($event);
    }
    elsif($options->{die}) {
        die($event);
    }
    $event;
}


####
# Take the listify Perl structure and convert it to
# a readable ASCII format.
#
sub secsify
{
     shift if UNIVERSAL::isa($_[0],__PACKAGE__);

     my @secs_obj = @{shift @_};  # separate copy so do not clobber @_;

     $default_options = Data::Secs2->new() unless $default_options;
     my $options = $default_options->override(@_);

     my $spaces = $options->{spaces};
     $spaces = '  ' unless $spaces;
     my $indent = '';
     my $length = 0;

     my @level = ();

     my ($format, $element);
     my $string = '';

     while (@secs_obj) {

         $format = shift @secs_obj;
         if(@level && $level[-1] <= 0) {
             while (@level && $level[-1] <= 0) {pop @level};
             $indent = $options->{type} eq 'ascii' ? $spaces x scalar @level : '';
         }
         if ($format eq 'L') {
             $length = shift @secs_obj;
             $element = secs_elementify( $format . $length, undef, $options );
             goto EVENT if ref($element);
             $string .= $indent . $element;
             $level[-1] -= 1 if @level;
             push @level, $length;
             $indent = $options->{type} eq 'ascii' ? $spaces x scalar @level : '';
             $length =  0;
         }
         elsif ($format =~ /[SUF]\d/) {
             $element = secs_elementify($format,shift @secs_obj, $options);
             goto EVENT if ref($element);
             $string .= $indent . $element;
             $level[-1] -= 1 if @level;
         }
         elsif ($format =~ /[AJBTN]/) {
             $element = secs_elementify( $format, shift @secs_obj, $options);
             goto EVENT if ref($element);
             $string .= $indent . $element;
             $level[-1] -= 1 if @level;
         }
         else {
             my $event = "Unknown format $format\n";
             $element = \$event;
             goto EVENT;
         }
         $string .= "\n" if substr($string, -1, 1) ne "\n" && $options->{type} =~ /asc/i;

     };

     ########
     # Stingified SECSII message of a Perl Nested Data
     #
     return $string;

EVENT:
     my $event = "# EVENT Data::Secs2::secsify $VERSION\n" . $$element;
     $event .= "\n" if substr($$element,-1,1) ne "\n";
     $string = "\n" . $string;
     $event .= 'B[' . length($string) . "] " . $string;
     if($options->{warnings} ) {
         warn($event);
     }
     elsif($options->{die}) {
         die($event);
     }
     \$event;
}

####
# Used in this program module only by the secsify subroutine
#
sub secs_elementify
{
     my $event;
     shift if UNIVERSAL::isa($_[0],__PACKAGE__);

     ########
     # Two type of inputs:
     #   list element:  $format @options
     #   item element:  $format $cells @options
     #
     #
     my ($format, $cells, @options) = @_;

     $default_options = Data::Secs2->new() unless $default_options;
     my $options = $default_options->override(@options);

     my ($length,$body_bytes);
     if($format =~ 'L(\d+)') {
        $format = 'L';
        $length = $1;
     }

     my $body;
     if($options->{type} eq 'ascii') {
         $body = $format;
         if($format eq 'L') {
             $body .= '[' . $length . ']';
         }
         elsif ($format =~ /[SUF]\d/ || $format eq 'T' || $format eq 'N') {
             if(ref($cells) eq 'ARRAY') {
                 $body .= '[' . (scalar @$cells) . ']';
                 $body .= ' ' . (join ' ' , @$cells) if @$cells;
             }
             else {
                 $body .= ' ' . $cells if defined($cells);
             }
         }
         elsif ($format =~ /[AJB]/) {
             $body .= '[' . length($cells) . ']';
             $body .= ($cells =~ /\n/) ? "\n" : ' ' if $cells;
             $body .= $cells;
         }
         elsif( $format !~ /[L]/ ) {
             $event =  "Unknown format, $format\n";
             goto EVENT;
         }
     }
     else {
         require Data::SecsPack;
         if ($format =~ /[SUF]\d/ || $format eq 'T' || $format eq 'N') {
             my $number;
             $format = 'I' if $format eq 'N';
             if(ref($cells) eq 'ARRAY') {
                 ($format, $number) = Data::SecsPack->pack_num($format, @$cells, $options->{'Data::SecsPack'});
             }
             else {
                 ($format, $number) = Data::SecsPack->pack_num($format, $cells, $options->{'Data::SecsPack'});
                 if($options->{scalar}) {
                     return pack("C1",$format{$format}) . $number;
                 }
             }
             if(defined($format)) {
                 $cells = $number;
             }
             else {
                 $event = "Could not pack number.\n";
                 goto EVENT;
             }
         }
         $body_bytes = $format eq 'L' ? $length : length($cells);
         my ($len_format,$len_num) = Data::SecsPack->pack_num('I', $body_bytes, $options->{'Data::SecsPack'});
         unless(defined($len_format) && $len_format =~ /^U/ ) {
             $event =  "Element length number is not unsigned integer\n";
             goto EVENT;
         }
         my $len_size = length($len_num);
         unless($len_size < 4) {
             $event = "Number of cells in the item is too big\n";
             goto EVENT;
         }
         $body = pack ("C1",($format{$format}+$len_size)) . $len_num;
         return $body if $format eq 'L' || $body_bytes == 0;
         $body .= $cells;
     }
     return $body;

EVENT:
    $event .= "\tData::Secs2::secs_elementify $VERSION\n";
    if($options->{warnings} ) {
        warn($event);
    }
    elsif($options->{die}) {
        die($event);
    }
    \$event;
}

#####
# If the variable is not a scalar,
# stringify it.
#
sub stringify
{
     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
     return $_[0] unless ref($_[0]) ||  1 < @_;
     secsify(listify(@_));

}

sub transify
{

     ######
     # This subroutine uses no object data; therefore,
     # drop any class or object.
     #
     my $event;
     shift if UNIVERSAL::isa($_[0],__PACKAGE__);

     my $ascii_secs = shift;

     $default_options = Data::Secs2->new() unless $default_options;
     my $options = $default_options->override(@_);

     #####
     # Data format code S - Secsii  P - Perl
     my @secs_obj = ();
     my $obj_format_code = $options->{obj_format_code} if defined $options->{obj_format_code};
     if($options->{obj_format_code}) {
         unless( $options->{add_obj_format_code} ) {
             $ascii_secs =~ s/^\s*U1\s*(80|83)\s*\n?//s;
         }
         push @secs_obj,('U1',[unpack 'C1',$options->{obj_format_code}]);
     }

     use integer;
     my ($format, $byte_code, $bytes_per_cell, $length);
     my (@open_list, $list_location, $list_close_char, $item_count, $counted_list);
     my ($open_char, $close_char, $esc_esc, $str);
     $list_close_char = '';
     $list_location = 0;
     $item_count = 0;
     $counted_list = 0;
     my (@integers,$integer);
     $ascii_secs =~ s/^\s*//s;
     while($ascii_secs) {

          #####
          # Parse format code
          ($format,$byte_code) = ($1,$2) if $ascii_secs =~ s/^\s*(\S)(\d)?//;
          $byte_code = '' unless $byte_code;
          unless($format) {
              $event = "No format code\n";
              goto EVENT;
          }
          $bytes_per_cell = $byte_code;
          $bytes_per_cell = '' unless $bytes_per_cell;
          $item_count++;
          $bytes_per_cell = 1 unless $bytes_per_cell;

          ######
          # Look for number of elements in brackets jammed tight
          # against the format code. If not there then going to be
          # doing some parentheses type work.
          #
          $length = undef;
          $length = $1 if $ascii_secs =~ s/^s*\[\s*(\d+)\s*\]//s;
          unless (defined $length) {
              $length = $1 if $ascii_secs =~ s/^\s*\,\s*(\d+)//s;
          }
          my $skip = 1;
          if($ascii_secs) {
              if(substr($ascii_secs,0,2) eq '\r\n' || substr($ascii_secs,0,2) eq '\n\r') {
                  $skip = 2;
              }
              $ascii_secs = substr($ascii_secs,$skip);
          }
          ######
          # If length is specified, go with it.
          #
          unless($ascii_secs) {
              $event = "No element body.\n";
              goto EVENT;
          }
          if(defined $length) {
              if($format eq 'L') {
                  push @open_list,[$list_location,$list_close_char,$item_count,$counted_list] if $list_location;
                  $list_location = scalar @secs_obj + 1;
                  $item_count = 0;
                  $counted_list = $length;
                  $list_close_char = '';
                  $close_char = '';
                  push @secs_obj,$format,$length;
              }

              ####
              # Grab the length number of characters from input stream
              elsif($format =~ /^[JAB]$/) {
                  if(0 < $length) {
                      push @secs_obj,$format,substr($ascii_secs,0,$length);
                      $ascii_secs = substr($ascii_secs,$length);
                  }
                  else {
                      push @secs_obj,$format,'';  # length 0
                  }
              }

              #####
              # Count the numbers, should agree with length
              elsif ($format =~ /^[FNSTU]$/)  {
                  if(0 < $length) {
                       ($str, my @nums) = Data::Str2Num->str2float($ascii_secs, {ascii_float => 1});
                       $ascii_secs = join ' ',@$str;
                       if($length != @nums) {
                           $event = "Wrong number of numbers." ;
                           goto EVENT;
                       }
                       push @secs_obj, "$format$byte_code",\@nums;
                  }
                  else {
                      push @secs_obj,$format,'';  # length 0
                  }

              }
              else {
                  $event = "Unkown format $format, $format\n";
                  goto EVENT;
              }
          }

          else {

              ######
              # Count the numbers
              if( $format =~ /^[FNSTU]$/ ) {
                  ($str, my @nums) = Data::Str2Num->str2float($ascii_secs, {ascii_float => 1});
                  $ascii_secs = join ' ',@$str;
                  push @secs_obj, "$format$byte_code";
                  if(@nums == 0) {
                      push @secs_obj,'';
                  }
                  elsif(@nums == 1) {
                      push @secs_obj,$nums[0]; # scalar number
                  }
                  else {
                      push @secs_obj, \@nums;  # numeric array
                  }
              }

              elsif( $format =~ /^[LAJB]$/ ) {

                  ######
                  # Otherwise, look for parentheses type enclosing.
                  #
                  $open_char = $1 if $ascii_secs =~ s/^\s*(\S)//;
                  if($open_char eq '(') {
                      $close_char = ')';
                  }
                  elsif($open_char eq '[') {
                      $close_char = ']';
                  }
                  elsif($open_char eq '{') {
                      $close_char = '}';
                  }
                  elsif($open_char eq '<') {
                      $close_char = '>';
                  }
                  else {
                      $close_char = $open_char;
                  }

                  ####
                  # Need to save old list item count, list location, and start a new open list
                  if($format eq 'L') {

                      ####
                      # Note: For open list, there must be L at the even location. Does $list_location
                      # for an open list must always be odd and never can be zero.
                      push @open_list,[$list_location,$list_close_char,$item_count,$counted_list] if $list_location;
                      $list_location = scalar @secs_obj + 1;
                      $item_count = 0;
                      $counted_list = 0;
                      $list_close_char = $close_char;
                      $close_char = '';
                      push @secs_obj,$format,0;
                  }

                  ####
                  # Close a text string
                  else {

                      $str = '';
                      use integer;
                      for(;;) {
                          unless($ascii_secs =~ s/(.*?)\Q$close_char\E//s) {
                              $event = "No matching $close_char for $open_char\n\t$ascii_secs";
                              goto EVENT;
                          }
                          $str .= $1;
                          ($esc_esc) = $str =~ /(\\+)$/;

                          #####
                          # close_char escaped
                          if($esc_esc && length($esc_esc) % 2) {
                              $str .= $close_char;
                          }

                          else {
                              last;
                          }
                      }
                      no integer;
                      $close_char = '';
                      push @secs_obj,$format,$str;
                  }
              }
              else  {
                  $event = "Unkown format $format\n";
                  goto EVENT;
              }
          }

          ######
          # Try closing any open list
          while(($list_close_char && $ascii_secs =~ s/^\s*\Q$list_close_char\E//s) ||
              ($counted_list && $counted_list <= $item_count) ) {

              if($list_close_char && $counted_list ==0) {
                  $secs_obj[$list_location] = $item_count;
              }
              if(@open_list) {
                  ($list_location,$list_close_char,$item_count,$counted_list) = @{$open_list[-1]};
                  pop @open_list;
              }
              else {
                  $list_close_char = '';
                  $list_location = 0;
                  $item_count = 0;
                  $counted_list = 0;
                  $close_char = '';
              }
          }
          $ascii_secs =~ s/^\s*//s;
     }
     no integer;
     my $open_lists = scalar @open_list;
     $open_lists++ if $counted_list || $list_close_char;
     return \@secs_obj unless $open_lists;

     $event = "open lists: \n" ;
     $event .= Dumper(@open_list, [$list_location, $list_close_char, $item_count, $counted_list] );

EVENT:
    $event .= "\tascii_secs:\n" . $ascii_secs;
    $event .= "\tSECS object:\n";
    $event .= Dumper(@secs_obj);
    $event .= "\tSubroutine: Data::Secs2::transify $VERSION\n";
    if($options->{warnings} ) {
        warn($event);
    }
    elsif($options->{die}) {
        die($event);
    }
    $event;
}


1

__END__