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


line stmt bran cond sub pod time code
1             #!perl
2             #
3             # Documentation, copyright and license is at the end of this file.
4             #
5             package Data::Secs2;
6            
7 1     1   20486 use 5.001;
  1         7  
  1         40  
8 1     1   5 use strict;
  1         2  
  1         43  
9 1     1   7 use warnings;
  1         10  
  1         33  
10 1     1   7 use warnings::register;
  1         2  
  1         383  
11 1     1   1102 use attributes;
  1         1822  
  1         8  
12            
13 1     1   96 use vars qw($VERSION $DATE $FILE);
  1         2  
  1         111  
14             $VERSION = '1.25';
15             $DATE = '2004/05/20';
16             $FILE = __FILE__;
17            
18 1     1   471 use Data::Startup 0.02;
  1         1458  
  1         42  
19 1     1   463 use Data::Str2Num 0.05;
  1         2394  
  1         60  
20 1     1   1232 use Data::Dumper;
  1         12290  
  1         122  
21             $Data::Dumper::Sortkeys = 1; # dump hashes sorted
22             $Data::Dumper::Terse = 1; # avoid Varn Variables
23            
24 1     1   12 use vars qw(@ISA @EXPORT_OK $default_options);
  1         3  
  1         1816  
25             require Exporter;
26             @ISA=qw(Exporter Data::Startup);
27             @EXPORT_OK = qw(arrayify config listify neuterify numberify perlify
28             perl_typify secsify secs_elementify stringify textify
29             transify);
30            
31             $default_options = new Data::Secs2;
32            
33             #######
34             # Object used to set default, startup, options values.
35             #
36             sub new
37             {
38 1     1 1 3 my $class = shift;
39 1 50       5 $class = ref($class) if ref($class);
40 1         12 my $self = $class->Data::Startup::new(
41             die => 0,
42             add_obj_format_code => 0,
43             obj_format_code => '',
44             type => 'ascii',
45             scalar => 0,
46             spaces => ' ',
47             indent => '',
48             version => $VERSION,
49             warnings => 0,
50             );
51 1         30 $self->Data::Startup::override(@_);
52            
53             }
54            
55            
56             ######
57             # WARNING: For some unknow reason that needs investigation
58             # the use of SelfLoader causes massive failures, particular
59             # in the regards to interface with SecsPack
60             #
61             # use SelfLoader;
62             # 1
63             # __DATA__
64            
65            
66             ###########
67             # The keys for hashes are not sorted. In order to
68             # establish a canonical form for the hash, sort
69             # the hash and convert it to an array with a two
70             # leading control elements in the array.
71             #
72             # The elements determine if the data is an array
73             # or a hash and its reference.
74             #
75             sub arrayify
76             {
77             ######
78             # This subroutine uses no object data; therefore,
79             # drop any class or object.
80             #
81 0     0 1   my $event;
82 0 0         shift if UNIVERSAL::isa($_[0],__PACKAGE__);
83            
84 0           my ($var) = shift @_;
85            
86 0 0         $default_options = Data::Secs2->new() unless $default_options;
87 0           my $options = $default_options->override(@_);
88            
89 0           my $class = ref($var);
90 0 0         return $var unless $class;
91            
92 0           my $reftype = attributes::reftype($var);
93 0 0         $class = $class ne $reftype ? $class : '';
94 0           my @array = ($class,$reftype);
95            
96             #####
97             # Add rest of the members to the canoncial array
98             # based on underlying data type
99             #
100 0 0         if ( $reftype eq 'HASH') {
    0          
    0          
    0          
    0          
    0          
101 0           foreach (sort keys %$var ) {
102 0           push @array, ($_, $var->{$_});
103             }
104             }
105             elsif($reftype eq 'ARRAY') {
106 0           push @array, @$var;
107             }
108             elsif($reftype eq 'SCALAR') {
109 0           push @array, $$var;
110             }
111             elsif($reftype eq 'REF') {
112 0           push @array, $var;
113             }
114             elsif($reftype eq 'CODE') {
115 0           push @array, $var;
116             }
117             elsif($reftype eq 'GLOB') {
118 0           push @array,(*$var{SCALAR},*$var{ARRAY},*$var{HASH},*$var{CODE},
119             *$var{IO},*$var{NAME},*$var{PACKAGE},"*$var"),
120             }
121             else {
122 0           $event = "Unknown underlying data type\n";
123 0           @array = '';
124 0           goto EVENT;
125             }
126 0           return \@array;
127            
128 0           EVENT:
129             $event .= "\tData::Secs2::arrayify $VERSION\n";
130 0 0         if($options->{warnings} ) {
    0          
131 0           warn($event);
132             }
133             elsif($options->{die}) {
134 0           die($event);
135             }
136 0           $event;
137             }
138            
139            
140             ######
141             # Program module wide configuration
142             #
143             sub config
144             {
145 0 0   0 1   $default_options = Data::Secs2->new() unless $default_options;
146 0 0         my $self = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : $default_options;
147 0 0         $self = ref($self) ? $self : $default_options;
148 0           $self->Data::Startup::config(@_);
149            
150             }
151            
152            
153             #######
154             #
155             #
156             my %format = (
157             L => 0x00, # List (length in elements)
158             B => 0x20, # Binary
159             T => 0x24, # Boolean
160             A => 0x40, # ASCII
161             J => 0x44, # JIS-8
162             S8 => 0x60, # 8-byte integer (unsigned)
163             S1 => 0x62, # 1-byte integer (unsigned)
164             S2 => 0x64, # 2-byte integer (unsigned)
165             S4 => 0x70, # 4-byte integer (unsigned)
166             F8 => 0x80, # 8-byte floating
167             F4 => 0x90, # 4-byte floating
168             U8 => 0xA0, # 8-byte integer (unsigned)
169             U1 => 0xA4, # 1-byte integer (unsigned)
170             U2 => 0xA8, # 2-byte integer (unsigned)
171             U4 => 0xB0, # 4-byte integer (unsigned)
172             );
173            
174            
175            
176            
177             ################
178             # This subroutine walks a nested data structure, and listify each level
179             # into a perlified SECII message. The assumption is that the nested
180             # data structure consists of only references to Perl arrays,
181             #
182             sub listify
183             {
184            
185             ######
186             # This subroutine uses no object data; therefore,
187             # drop any class or object.
188             #
189 0 0   0 1   $default_options = Data::Secs2->new() unless $default_options;
190 0 0         my $self = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : $default_options;
191 0 0         $self = ref($self) ? $self : $default_options;
192 0           my %options = %$self; # try not to mangle or bless the default options
193            
194             #########
195             # Return an array, so going to walk the array, looking
196             # for hash and array references to arrayify
197             #
198             # Use a stack for the walk instead of recursing. Easier
199             # to maintain when the data is on a separate stack instead
200             # of the call (return) stack and only the pertient data
201             # is stored on the separate stack. The return stack does
202             # not grow. Instead the separate recurse stack grows.
203             #
204 0           my %dups = ();
205 0           my @vars = ();
206 0           my @index = ();
207            
208             #####
209             # Perl format code
210 0           my @secs_obj = ('U1',[80]);
211 0           my $i = 0;
212 0           my @var = @_; # do not clobber @_ so make a copy
213 0           my $var = \@var;
214 0           my ($is_numeric,$format,$num,$ref,$ref_dup,@dup_index,$str);
215            
216 0           for(;;) {
217            
218 0           while($i < @$var) {
219            
220             ######
221             # Index to the same reference structure in the nested data.
222             # First number is the number of indices. The indices are
223             # within each level of the nested listes.
224             #
225 0 0         $ref_dup = (ref($var->[$i])) ? "$var->[$i]" : '';
226 0 0         if( $dups{$ref_dup} ) {
227 0           push @secs_obj, ('L', '3', 'A', '', 'A', 'Index', 'N', $dups{$ref_dup});
228 0           $i++;
229 0           next;
230             }
231            
232            
233             #####
234             # Try to convert to a pack numeric array.
235 0 0         if (ref($var->[$i]) eq 'ARRAY') {
236            
237             #####
238             # Quit very coarse filter that eliminates many numerics
239             #
240 0           $is_numeric = 1;
241 0           foreach (@{$var->[$i]}) {
  0            
242 0 0 0       if (ref($_) && ref($_) ne 'ARRAY') {
243 0           $is_numeric = 0;
244 0           last;
245             }
246 0 0 0       unless (defined $_ && $_ =~ /\s*\S+\s*/ ) {
247 0           $is_numeric = 0;
248 0           last;
249             }
250             }
251 0 0         if($is_numeric) {
252 0           ($str, my @num) = Data::Str2Num->str2float(@{$var->[$i]}, {ascii_float => 1});
  0            
253 0 0 0       if(@num != 0 && @$str == 0) {
254 0           push @secs_obj, 'N', \@num;
255 0           $i++;
256 0           next;
257             }
258             }
259             }
260            
261 0           $var->[$i] = arrayify( $var->[$i] );
262 0           $ref = ref($var->[$i]);
263            
264             ####
265             # If $var->[$i] is a reference it is a reference to an array of
266             # an underlying data type or object that is arrayified.
267             #
268 0 0         if ($ref) {
269            
270 0           $dups{$ref_dup} = (scalar @secs_obj); # element in @secs_obj
271            
272             ########
273             # Nest for an 'ARRAY' reference to the arrayified the refereceddata
274             #
275             # The listify subroutine uses @vars stacks to nest. When listify finds
276             # member of the current array that is a reference to another array,
277             # listify stops working on the current array. It save the position
278             # that it stop working by pushing a refenrence to the current array
279             # and the position (index), $i of the array reference onto the @vars
280             # stack. Listify will then start working on the new array. When all work
281             # on the new array is listify will pop the old $var array reference
282             # and array index $i off of the @vars stack and continue work on the
283             # old array.
284             #
285 0 0         if($ref eq 'ARRAY' ) {
286            
287             ####
288             # Save info so listify can resume work on the old array
289             #
290 0           push @vars, ($var,$i+1);
291            
292             ####
293             # Start work on the new array
294             #
295 0           $var = $var->[$i];
296 0           $i = 0;
297            
298             #####
299             # Output a List element whose body is the number of
300             # members in the new array that listify is starting
301             # to work on.
302             #
303 0           push @secs_obj, ('L', scalar @$var);
304 0           next;
305             }
306             }
307            
308             ########
309             # Otherwise, a pure simple scalar
310             #
311             else {
312            
313             #####
314             # An undefined is translated to SECSII data structure as L[0]
315             #
316 0 0         if(defined $var->[$i]) {
317            
318             ######
319             # Try for a single packed number type
320             #
321 0           ($str,my @num) = Data::Str2Num->str2float($var->[$i], {ascii_float => 1});
322 0 0 0       if(@num == 1 && @$str == 0) {
323 0           push @secs_obj, 'N', $num[0];
324             }
325            
326             #####
327             # Else ascii
328             else {
329 0           push @secs_obj, 'A', $var->[$i];
330             }
331             }
332             else {
333 0           push @secs_obj, 'L', 0;
334             }
335            
336             }
337 0           $i++;
338             }
339            
340             #####
341             # At the end of the current array, so go back
342             # working on any array whose work was interupted
343             # to work on the current array.
344             #
345 0 0         last unless @vars;
346 0           ($var,$i) = splice( @vars, -2, 2);
347            
348             }
349            
350             ########
351             # Listified unpacked SECSII message
352             #
353 0           \@secs_obj;
354            
355             }
356            
357            
358             #######
359             #
360             #
361             my @bin_format = (
362             'L', # 0 List (length in elements)
363             '', # 1
364             '', # 2
365             '', # 3
366             '', # 4
367             '', # 5
368             '', # 6
369             '', # 7
370             'B', # 8 Binary
371             'T', # 9 Boolean
372             '', # 10
373             '', # 11
374             '', # 12
375             '', # 13
376             '', # 14
377             '', # 15
378             'A', # 16 ASCII
379             'J', # 17 JIS-8
380             '', # 18
381             '', # 19
382             '', # 20
383             '', # 21
384             '', # 22
385             '', # 23
386             'S8', # 24 8-byte integer (unsigned)
387             'S1', # 25 1-byte integer (unsigned)
388             'S2', # 26 2-byte integer (unsigned)
389             '', # 27
390             'S4', # 28 4-byte integer (unsigned)
391             '', # 29
392             '', # 30
393             '', # 31
394             'F8', # 32 8-byte floating
395             '', # 33
396             '', # 34
397             '', # 35
398             'F4', # 36 4-byte floating
399             '', # 37
400             '', # 38
401             '', # 39
402             'U8', # 40 8-byte integer (unsigned)
403             'U1', # 41 1-byte integer (unsigned)
404             'U2', # 42 2-byte integer (unsigned)
405             '', # 43
406             'U4', # 44 4-byte integer (unsigned)
407             '', # 45
408             '', # 46
409             '', # 47
410             '', # 48
411             '', # 49
412             '', # 50
413             '', # 51
414             '', # 52
415             '', # 53
416             '', # 54
417             '', # 55
418             '', # 56
419             '', # 57
420             '', # 58
421             '', # 59
422             '', # 60
423             '', # 61
424             '', # 63
425             );
426            
427            
428            
429             ####
430             #
431             #
432             sub neuterify
433             {
434 0     0 1   require Data::SecsPack;
435            
436             ######
437             # This subroutine uses no object data; therefore,
438             # drop any class or object.
439             #
440 0           my $event;
441 0 0         shift if UNIVERSAL::isa($_[0],__PACKAGE__);
442            
443 0           my $binary_secs = shift;
444            
445 0 0         $default_options = Data::Secs2->new() unless $default_options;
446 0           my $options = $default_options->override(@_);
447            
448 0           my @secs_format_element = unpack('C3',$binary_secs);
449 0           my @secs_obj = ();
450            
451             #####
452             # Data format code S - Secsii P - Perl
453 0 0         my $obj_format_code = $options->{obj_format_code} if defined $options->{obj_format_code};
454 0 0         if( $options->{$obj_format_code} ) {
455 0 0 0       if(!$options->{add_obj_format_code} && $secs_format_element[0] == 165
      0        
      0        
      0        
456             && $secs_format_element[1] == 1 &&
457             ($secs_format_element[2] == 80 || $secs_format_element[2] == 83) ) {
458 0           substr($binary_secs,2,1) = $options->{$obj_format_code};
459             }
460             else {
461 0           @secs_obj = ('U1',[unpack 'C1',$options->{obj_format_code}]);
462             }
463             }
464            
465 1     1   1277 use integer;
  1         12  
  1         6  
466 0           my ($format, $bytes_per_cell, $length_size, $length, $length_num, $number);
467 0           while($binary_secs) {
468            
469             #####
470             # Decode format byte
471 0           $format = unpack('C1',$binary_secs);
472 0           $binary_secs = substr($binary_secs,1);
473 0           $length_size = $format & 0x03;
474 0           $format = $bin_format[($format & 0xFC) >> 2];
475 0 0         unless($format) {
476 0           $event = "Unknown SECSII format, $format\n";
477 0           goto EVENT;
478             }
479 0           push @secs_obj,$format;
480            
481             ######
482             # SEMI E5-94, 6.2.1, 6.3.1.
483             # A zero-length in the format byte is illegal and produces an error.
484             #
485             # The scalar option allows for A non-compliant SEMI E5-94 where a
486             # a zero-length in the format byte signals a single cell scalar follows.
487             #
488 0 0         if($length_size == 0 ) {
489 0 0 0       if( $options->{scalar} && $format ne 'L') {
490 0 0         $bytes_per_cell = $format =~ /(\d)$/ ? $1 : 1;
491 0 0 0       if( $format =~ /[SUF]\d/ || $format eq 'T') {
492 0           $number = Data::SecsPack->unpack_num( $format,
493             substr($binary_secs,0,$bytes_per_cell),
494             $options->{'Data::SecsPack'});
495 0 0         unless(ref($number) eq 'ARRAY') {
496 0           $event = $number;
497 0           goto EVENT;
498             }
499 0 0         if(@$number != 1) {
500 0           $event = 'Number ' . (join ' ',@$number) . "not a scalar\n" ;
501 0           goto EVENT;
502             }
503 0           push @secs_obj,$number->[0];
504             }
505             else {
506 0           push @secs_obj,substr($binary_secs,0,$bytes_per_cell);
507             }
508 0           $binary_secs = substr($binary_secs,$bytes_per_cell);
509 0           next;
510             }
511             else {
512 0           $event = "Format byte length size field is zero.\n";
513 0           goto EVENT;
514             }
515             }
516            
517             #####
518             # decode number of elements
519 0           $length = substr($binary_secs,0,$length_size);
520 0           $binary_secs = substr($binary_secs,$length_size);
521 0           $length_num = Data::SecsPack->unpack_num('U1', $length, $options->{'Data::SecsPack'});
522 0 0         unless(ref($length_num) eq 'ARRAY') {
523 0           $event = "Bad length\n";
524 0           goto EVENT;
525             }
526 0           $length_num = ${$length_num}[0];
  0            
527            
528             ######
529             # Grab the elements
530 0 0         if($format eq 'L') {
    0          
531 0           push @secs_obj,$length_num;
532             }
533             elsif($length_num) {
534 0 0 0       if( $format =~ /[SUF]\d/ || $format eq 'T') {
535 0           $number = Data::SecsPack->unpack_num( $format,
536             substr($binary_secs,0,$length_num), $options->{'Data::SecsPack'});
537 0 0         unless (ref($number) eq 'ARRAY') {
538 0           $event = $number;
539 0           goto EVENT;
540             }
541 0           push @secs_obj,$number;
542             }
543             else {
544 0           push @secs_obj,substr($binary_secs,0,$length_num);
545             }
546 0           $binary_secs = substr($binary_secs,$length_num);
547             }
548             else {
549 0           push @secs_obj,'';
550             }
551             }
552 1     1   707 no integer;
  1         1  
  1         7  
553 0           return \@secs_obj;
554            
555 0           EVENT:
556             $event .= "\tData::Secs2::neuterify $VERSION\n";
557 0 0         if($options->{warnings} ) {
    0          
558 0           warn($event);
559             }
560             elsif($options->{die}) {
561 0           die($event);
562             }
563 0           $event;
564             }
565            
566            
567             #####
568             #
569             #
570             sub perlify
571             {
572             ######
573             # This subroutine uses no object data; therefore,
574             # drop any class or object.
575             #
576 0     0 1   my $event;
577 0 0         shift if UNIVERSAL::isa($_[0],__PACKAGE__);
578            
579             ########
580             # Listified unpacked SECSII message
581             #
582 0           my $secs_obj = shift @_;
583            
584 0 0         $default_options = Data::Secs2->new() unless $default_options;
585 0           my $options = $default_options->override(@_);
586            
587 0           my @nested_stack = ();
588            
589 0           my ($head, $body);
590 0           my ($class, $type);
591            
592             #####
593             # Establish root array with a count that goes on
594             # until the $secs_obj is exhasted.
595             #
596 0           my $new_var_p;
597 0           my $count = -1;
598 0           my @root_array = ('','ARRAY');
599 0           my $nested_var_p = \@root_array;
600 0           my (%dup,$position);
601            
602 0           $head = $secs_obj->[0];
603 0           $body = $secs_obj->[1];
604 0 0 0       unless ($head eq 'U1' && ref($body) eq 'ARRAY' && @$body == 1 && $$body[0] eq '80') {
      0        
      0        
605 0           $event = "Not a Perl SECS object\n";
606 0           goto EVENT;
607             }
608            
609 0           my $i = 2;
610 0           while($i < @{$secs_obj} ) {
  0            
611            
612 0           $head = $secs_obj->[$i++];
613 0           $body = $secs_obj->[$i++];
614 0 0         if( $head eq 'L') {
    0          
615            
616 0 0         if($body == 0) {
617 0           push @$nested_var_p, undef;
618 0           $count--;
619             }
620             else {
621 0 0         if ('A' ne $secs_obj->[$i++]) {
622 0           $event = "Wrong format for Perl reference class, $secs_obj->[$i-1]\n" ;
623 0           goto EVENT;
624             }
625 0           $class = $secs_obj->[$i++];
626 0 0         if ('A' ne $secs_obj->[$i++]) {
627 0           $event = "Wrong format type for Perl reference underlying data type, $secs_obj->[$i-1]\n";
628 0           goto EVENT;
629             }
630 0           $type = $secs_obj->[$i++];
631 0 0         unless ($i < @{$secs_obj}) {
  0            
632 0           $event = "No body for Perl reference.\n" ;
633 0           goto EVENT;
634             }
635 0 0 0       if( $class eq '' && $type eq 'Index') {
636 0           $head = $secs_obj->[$i++];
637 0 0         unless($head =~ /^[UN]/) {
638 0           $event = "Perl index item has wrong format code, $head \n";
639 0           goto EVENT;
640             }
641 0           $body = $secs_obj->[$i++];
642 0 0         if(ref($body) eq 'ARRAY') {
643 0 0         unless (@$body == 1) {
644 0           $event = "Perl Index body must have only one cell\n";
645 0           goto EVENT;
646             }
647 0           $body = $body->[0];
648             }
649 0           $new_var_p = $dup{$body};
650 0           push @$nested_var_p, $new_var_p;
651 0           $count--;
652             }
653             else {
654            
655             #######
656             # The position $i - 6 is the index into @secs_obj of the
657             # element $head 'L'. This is the position that appears in
658             # Perl 'L', 3, 'A', '','A','Index',U1, $position Index
659             # list element.
660             #
661 0           $new_var_p = [$class,$type];
662 0           push @nested_stack,$nested_var_p, $count-1, $i - 6;
663 0           $nested_var_p = $new_var_p;
664 0           $count = $body-2;
665             }
666             }
667             }
668             elsif( $head =~ /^[AJBFNSTU]/ ) {
669 0           push @$nested_var_p,$body;
670 0           $count--;
671             }
672             else {
673 0           $event = "Unknown format type, $head\n";
674 0           goto EVENT;
675             }
676            
677             #####
678             # At the end of the current array, so go back
679             # working on any array whose work was interupted
680             # to work on the current array.
681             #
682 0   0       while(@nested_stack && $count <= 0) {
683 0 0         last unless $count == 0;
684 0           $new_var_p = perl_typify($nested_var_p);
685 0           ($nested_var_p, $count, $position) = splice(@nested_stack,-3,3);
686 0           push @$nested_var_p, $new_var_p;
687 0           $dup{$position} = $new_var_p;
688             }
689             }
690 0           $nested_var_p = perl_typify($nested_var_p);
691 0           return $nested_var_p;
692            
693 0           EVENT:
694             $event .= "\tData::Secs2::perlify $VERSION\n";
695 0 0         if($options->{warnings} ) {
    0          
696 0           warn($event);
697             }
698             elsif($options->{die}) {
699 0           die($event);
700             }
701 0           $event;
702             }
703            
704            
705             ######
706             #
707             #
708             sub perl_typify
709             {
710 0 0   0 1   shift if UNIVERSAL::isa($_[0],__PACKAGE__);
711            
712 0           my $event;
713 0           my ($array) = (@_);
714            
715 0 0         $default_options = Data::Secs2->new() unless $default_options;
716 0           my $options = $default_options->override(@_);
717            
718 0           my @array = @$array;
719 0           my $class = shift @array;
720 0           my $reftype = shift @array;
721 0           my $ref;
722            
723             #####
724             # Add rest of the members to the canoncial array
725             # based on underlying data type
726             #
727 0 0         if ( $reftype eq 'HASH') {
    0          
    0          
    0          
    0          
    0          
728 0           $ref = {@array};
729             }
730             elsif($reftype eq 'ARRAY') {
731 0           $ref = \@array;
732             }
733             elsif($reftype eq 'SCALAR') {
734 0 0         unless( @array == 1) {
735 0           $event = "Bad scalar body\n";
736 0           goto EVENT;
737             }
738 0           $ref = \$array[0];
739             }
740             elsif($reftype eq 'REF') {
741 0 0         unless( @array == 1) {
742 0           $event = "Bad ref body\n";
743 0           goto EVENT;
744             }
745 0           $ref = $array[0];
746             }
747             elsif($reftype eq 'CODE') {
748 0 0         unless( @array == 1) {
749 0           $event = "Bad code body.\n";
750 0           goto EVENT;
751             }
752 0           $ref = $array[0];
753             }
754             elsif($reftype eq 'GLOB') {
755 0 0         unless(@array == 8) {
756 0           $event = "Bad glob body\n";
757 0           goto EVENT;
758             }
759 0           $ref = \@array;
760             }
761             else {
762 0           $event = "Unknown underlying data type, $reftype\n";
763 0           goto EVENT;
764             }
765 0 0         $ref = bless $ref,$class if($class);
766 0           return($ref);
767            
768 0           EVENT:
769             $event .= "\tData::Secs2::perl_typify $VERSION\n";
770 0 0         if($options->{warnings} ) {
    0          
771 0           warn($event);
772             }
773             elsif($options->{die}) {
774 0           die($event);
775             }
776 0           $event;
777             }
778            
779            
780             ####
781             # Take the listify Perl structure and convert it to
782             # a readable ASCII format.
783             #
784             sub secsify
785             {
786 0 0   0 1   shift if UNIVERSAL::isa($_[0],__PACKAGE__);
787            
788 0           my @secs_obj = @{shift @_}; # separate copy so do not clobber @_;
  0            
789            
790 0 0         $default_options = Data::Secs2->new() unless $default_options;
791 0           my $options = $default_options->override(@_);
792            
793 0           my $spaces = $options->{spaces};
794 0 0         $spaces = ' ' unless $spaces;
795 0           my $indent = '';
796 0           my $length = 0;
797            
798 0           my @level = ();
799            
800 0           my ($format, $element);
801 0           my $string = '';
802            
803 0           while (@secs_obj) {
804            
805 0           $format = shift @secs_obj;
806 0 0 0       if(@level && $level[-1] <= 0) {
807 0   0       while (@level && $level[-1] <= 0) {pop @level};
  0            
808 0 0         $indent = $options->{type} eq 'ascii' ? $spaces x scalar @level : '';
809             }
810 0 0         if ($format eq 'L') {
    0          
    0          
811 0           $length = shift @secs_obj;
812 0           $element = secs_elementify( $format . $length, undef, $options );
813 0 0         goto EVENT if ref($element);
814 0           $string .= $indent . $element;
815 0 0         $level[-1] -= 1 if @level;
816 0           push @level, $length;
817 0 0         $indent = $options->{type} eq 'ascii' ? $spaces x scalar @level : '';
818 0           $length = 0;
819             }
820             elsif ($format =~ /[SUF]\d/) {
821 0           $element = secs_elementify($format,shift @secs_obj, $options);
822 0 0         goto EVENT if ref($element);
823 0           $string .= $indent . $element;
824 0 0         $level[-1] -= 1 if @level;
825             }
826             elsif ($format =~ /[AJBTN]/) {
827 0           $element = secs_elementify( $format, shift @secs_obj, $options);
828 0 0         goto EVENT if ref($element);
829 0           $string .= $indent . $element;
830 0 0         $level[-1] -= 1 if @level;
831             }
832             else {
833 0           my $event = "Unknown format $format\n";
834 0           $element = \$event;
835 0           goto EVENT;
836             }
837 0 0 0       $string .= "\n" if substr($string, -1, 1) ne "\n" && $options->{type} =~ /asc/i;
838            
839             };
840            
841             ########
842             # Stingified SECSII message of a Perl Nested Data
843             #
844 0           return $string;
845            
846 0           EVENT:
847             my $event = "# EVENT Data::Secs2::secsify $VERSION\n" . $$element;
848 0 0         $event .= "\n" if substr($$element,-1,1) ne "\n";
849 0           $string = "\n" . $string;
850 0           $event .= 'B[' . length($string) . "] " . $string;
851 0 0         if($options->{warnings} ) {
    0          
852 0           warn($event);
853             }
854             elsif($options->{die}) {
855 0           die($event);
856             }
857 0           \$event;
858             }
859            
860             ####
861             # Used in this program module only by the secsify subroutine
862             #
863             sub secs_elementify
864             {
865 0     0 1   my $event;
866 0 0         shift if UNIVERSAL::isa($_[0],__PACKAGE__);
867            
868             ########
869             # Two type of inputs:
870             # list element: $format @options
871             # item element: $format $cells @options
872             #
873             #
874 0           my ($format, $cells, @options) = @_;
875            
876 0 0         $default_options = Data::Secs2->new() unless $default_options;
877 0           my $options = $default_options->override(@options);
878            
879 0           my ($length,$body_bytes);
880 0 0         if($format =~ 'L(\d+)') {
881 0           $format = 'L';
882 0           $length = $1;
883             }
884            
885 0           my $body;
886 0 0         if($options->{type} eq 'ascii') {
887 0           $body = $format;
888 0 0 0       if($format eq 'L') {
    0 0        
    0          
    0          
889 0           $body .= '[' . $length . ']';
890             }
891             elsif ($format =~ /[SUF]\d/ || $format eq 'T' || $format eq 'N') {
892 0 0         if(ref($cells) eq 'ARRAY') {
893 0           $body .= '[' . (scalar @$cells) . ']';
894 0 0         $body .= ' ' . (join ' ' , @$cells) if @$cells;
895             }
896             else {
897 0 0         $body .= ' ' . $cells if defined($cells);
898             }
899             }
900             elsif ($format =~ /[AJB]/) {
901 0           $body .= '[' . length($cells) . ']';
902 0 0         $body .= ($cells =~ /\n/) ? "\n" : ' ' if $cells;
    0          
903 0           $body .= $cells;
904             }
905             elsif( $format !~ /[L]/ ) {
906 0           $event = "Unknown format, $format\n";
907 0           goto EVENT;
908             }
909             }
910             else {
911 0           require Data::SecsPack;
912 0 0 0       if ($format =~ /[SUF]\d/ || $format eq 'T' || $format eq 'N') {
      0        
913 0           my $number;
914 0 0         $format = 'I' if $format eq 'N';
915 0 0         if(ref($cells) eq 'ARRAY') {
916 0           ($format, $number) = Data::SecsPack->pack_num($format, @$cells, $options->{'Data::SecsPack'});
917             }
918             else {
919 0           ($format, $number) = Data::SecsPack->pack_num($format, $cells, $options->{'Data::SecsPack'});
920 0 0         if($options->{scalar}) {
921 0           return pack("C1",$format{$format}) . $number;
922             }
923             }
924 0 0         if(defined($format)) {
925 0           $cells = $number;
926             }
927             else {
928 0           $event = "Could not pack number.\n";
929 0           goto EVENT;
930             }
931             }
932 0 0         $body_bytes = $format eq 'L' ? $length : length($cells);
933 0           my ($len_format,$len_num) = Data::SecsPack->pack_num('I', $body_bytes, $options->{'Data::SecsPack'});
934 0 0 0       unless(defined($len_format) && $len_format =~ /^U/ ) {
935 0           $event = "Element length number is not unsigned integer\n";
936 0           goto EVENT;
937             }
938 0           my $len_size = length($len_num);
939 0 0         unless($len_size < 4) {
940 0           $event = "Number of cells in the item is too big\n";
941 0           goto EVENT;
942             }
943 0           $body = pack ("C1",($format{$format}+$len_size)) . $len_num;
944 0 0 0       return $body if $format eq 'L' || $body_bytes == 0;
945 0           $body .= $cells;
946             }
947 0           return $body;
948            
949 0           EVENT:
950             $event .= "\tData::Secs2::secs_elementify $VERSION\n";
951 0 0         if($options->{warnings} ) {
    0          
952 0           warn($event);
953             }
954             elsif($options->{die}) {
955 0           die($event);
956             }
957 0           \$event;
958             }
959            
960             #####
961             # If the variable is not a scalar,
962             # stringify it.
963             #
964             sub stringify
965             {
966 0 0   0 1   shift if UNIVERSAL::isa($_[0],__PACKAGE__);
967 0 0 0       return $_[0] unless ref($_[0]) || 1 < @_;
968 0           secsify(listify(@_));
969            
970             }
971            
972             sub transify
973             {
974            
975             ######
976             # This subroutine uses no object data; therefore,
977             # drop any class or object.
978             #
979 0     0 1   my $event;
980 0 0         shift if UNIVERSAL::isa($_[0],__PACKAGE__);
981            
982 0           my $ascii_secs = shift;
983            
984 0 0         $default_options = Data::Secs2->new() unless $default_options;
985 0           my $options = $default_options->override(@_);
986            
987             #####
988             # Data format code S - Secsii P - Perl
989 0           my @secs_obj = ();
990 0 0         my $obj_format_code = $options->{obj_format_code} if defined $options->{obj_format_code};
991 0 0         if($options->{obj_format_code}) {
992 0 0         unless( $options->{add_obj_format_code} ) {
993 0           $ascii_secs =~ s/^\s*U1\s*(80|83)\s*\n?//s;
994             }
995 0           push @secs_obj,('U1',[unpack 'C1',$options->{obj_format_code}]);
996             }
997            
998 1     1   2952 use integer;
  1         2  
  1         5  
999 0           my ($format, $byte_code, $bytes_per_cell, $length);
1000 0           my (@open_list, $list_location, $list_close_char, $item_count, $counted_list);
1001 0           my ($open_char, $close_char, $esc_esc, $str);
1002 0           $list_close_char = '';
1003 0           $list_location = 0;
1004 0           $item_count = 0;
1005 0           $counted_list = 0;
1006 0           my (@integers,$integer);
1007 0           $ascii_secs =~ s/^\s*//s;
1008 0           while($ascii_secs) {
1009            
1010             #####
1011             # Parse format code
1012 0 0         ($format,$byte_code) = ($1,$2) if $ascii_secs =~ s/^\s*(\S)(\d)?//;
1013 0 0         $byte_code = '' unless $byte_code;
1014 0 0         unless($format) {
1015 0           $event = "No format code\n";
1016 0           goto EVENT;
1017             }
1018 0           $bytes_per_cell = $byte_code;
1019 0 0         $bytes_per_cell = '' unless $bytes_per_cell;
1020 0           $item_count++;
1021 0 0         $bytes_per_cell = 1 unless $bytes_per_cell;
1022            
1023             ######
1024             # Look for number of elements in brackets jammed tight
1025             # against the format code. If not there then going to be
1026             # doing some parentheses type work.
1027             #
1028 0           $length = undef;
1029 0 0         $length = $1 if $ascii_secs =~ s/^s*\[\s*(\d+)\s*\]//s;
1030 0 0         unless (defined $length) {
1031 0 0         $length = $1 if $ascii_secs =~ s/^\s*\,\s*(\d+)//s;
1032             }
1033 0           my $skip = 1;
1034 0 0         if($ascii_secs) {
1035 0 0 0       if(substr($ascii_secs,0,2) eq '\r\n' || substr($ascii_secs,0,2) eq '\n\r') {
1036 0           $skip = 2;
1037             }
1038 0           $ascii_secs = substr($ascii_secs,$skip);
1039             }
1040             ######
1041             # If length is specified, go with it.
1042             #
1043 0 0         unless($ascii_secs) {
1044 0           $event = "No element body.\n";
1045 0           goto EVENT;
1046             }
1047 0 0         if(defined $length) {
1048 0 0         if($format eq 'L') {
    0          
    0          
1049 0 0         push @open_list,[$list_location,$list_close_char,$item_count,$counted_list] if $list_location;
1050 0           $list_location = scalar @secs_obj + 1;
1051 0           $item_count = 0;
1052 0           $counted_list = $length;
1053 0           $list_close_char = '';
1054 0           $close_char = '';
1055 0           push @secs_obj,$format,$length;
1056             }
1057            
1058             ####
1059             # Grab the length number of characters from input stream
1060             elsif($format =~ /^[JAB]$/) {
1061 0 0         if(0 < $length) {
1062 0           push @secs_obj,$format,substr($ascii_secs,0,$length);
1063 0           $ascii_secs = substr($ascii_secs,$length);
1064             }
1065             else {
1066 0           push @secs_obj,$format,''; # length 0
1067             }
1068             }
1069            
1070             #####
1071             # Count the numbers, should agree with length
1072             elsif ($format =~ /^[FNSTU]$/) {
1073 0 0         if(0 < $length) {
1074 0           ($str, my @nums) = Data::Str2Num->str2float($ascii_secs, {ascii_float => 1});
1075 0           $ascii_secs = join ' ',@$str;
1076 0 0         if($length != @nums) {
1077 0           $event = "Wrong number of numbers." ;
1078 0           goto EVENT;
1079             }
1080 0           push @secs_obj, "$format$byte_code",\@nums;
1081             }
1082             else {
1083 0           push @secs_obj,$format,''; # length 0
1084             }
1085            
1086             }
1087             else {
1088 0           $event = "Unkown format $format, $format\n";
1089 0           goto EVENT;
1090             }
1091             }
1092            
1093             else {
1094            
1095             ######
1096             # Count the numbers
1097 0 0         if( $format =~ /^[FNSTU]$/ ) {
    0          
1098 0           ($str, my @nums) = Data::Str2Num->str2float($ascii_secs, {ascii_float => 1});
1099 0           $ascii_secs = join ' ',@$str;
1100 0           push @secs_obj, "$format$byte_code";
1101 0 0         if(@nums == 0) {
    0          
1102 0           push @secs_obj,'';
1103             }
1104             elsif(@nums == 1) {
1105 0           push @secs_obj,$nums[0]; # scalar number
1106             }
1107             else {
1108 0           push @secs_obj, \@nums; # numeric array
1109             }
1110             }
1111            
1112             elsif( $format =~ /^[LAJB]$/ ) {
1113            
1114             ######
1115             # Otherwise, look for parentheses type enclosing.
1116             #
1117 0 0         $open_char = $1 if $ascii_secs =~ s/^\s*(\S)//;
1118 0 0         if($open_char eq '(') {
    0          
    0          
    0          
1119 0           $close_char = ')';
1120             }
1121             elsif($open_char eq '[') {
1122 0           $close_char = ']';
1123             }
1124             elsif($open_char eq '{') {
1125 0           $close_char = '}';
1126             }
1127             elsif($open_char eq '<') {
1128 0           $close_char = '>';
1129             }
1130             else {
1131 0           $close_char = $open_char;
1132             }
1133            
1134             ####
1135             # Need to save old list item count, list location, and start a new open list
1136 0 0         if($format eq 'L') {
1137            
1138             ####
1139             # Note: For open list, there must be L at the even location. Does $list_location
1140             # for an open list must always be odd and never can be zero.
1141 0 0         push @open_list,[$list_location,$list_close_char,$item_count,$counted_list] if $list_location;
1142 0           $list_location = scalar @secs_obj + 1;
1143 0           $item_count = 0;
1144 0           $counted_list = 0;
1145 0           $list_close_char = $close_char;
1146 0           $close_char = '';
1147 0           push @secs_obj,$format,0;
1148             }
1149            
1150             ####
1151             # Close a text string
1152             else {
1153            
1154 0           $str = '';
1155 1     1   913 use integer;
  1         3  
  1         4  
1156 0           for(;;) {
1157 0 0         unless($ascii_secs =~ s/(.*?)\Q$close_char\E//s) {
1158 0           $event = "No matching $close_char for $open_char\n\t$ascii_secs";
1159 0           goto EVENT;
1160             }
1161 0           $str .= $1;
1162 0           ($esc_esc) = $str =~ /(\\+)$/;
1163            
1164             #####
1165             # close_char escaped
1166 0 0 0       if($esc_esc && length($esc_esc) % 2) {
1167 0           $str .= $close_char;
1168             }
1169            
1170             else {
1171 0           last;
1172             }
1173             }
1174 1     1   156 no integer;
  1         3  
  1         4  
1175 0           $close_char = '';
1176 0           push @secs_obj,$format,$str;
1177             }
1178             }
1179             else {
1180 0           $event = "Unkown format $format\n";
1181 0           goto EVENT;
1182             }
1183             }
1184            
1185             ######
1186             # Try closing any open list
1187 0   0       while(($list_close_char && $ascii_secs =~ s/^\s*\Q$list_close_char\E//s) ||
      0        
      0        
1188             ($counted_list && $counted_list <= $item_count) ) {
1189            
1190 0 0 0       if($list_close_char && $counted_list ==0) {
1191 0           $secs_obj[$list_location] = $item_count;
1192             }
1193 0 0         if(@open_list) {
1194 0           ($list_location,$list_close_char,$item_count,$counted_list) = @{$open_list[-1]};
  0            
1195 0           pop @open_list;
1196             }
1197             else {
1198 0           $list_close_char = '';
1199 0           $list_location = 0;
1200 0           $item_count = 0;
1201 0           $counted_list = 0;
1202 0           $close_char = '';
1203             }
1204             }
1205 0           $ascii_secs =~ s/^\s*//s;
1206             }
1207 1     1   184 no integer;
  1         2  
  1         4  
1208 0           my $open_lists = scalar @open_list;
1209 0 0 0       $open_lists++ if $counted_list || $list_close_char;
1210 0 0         return \@secs_obj unless $open_lists;
1211            
1212 0           $event = "open lists: \n" ;
1213 0           $event .= Dumper(@open_list, [$list_location, $list_close_char, $item_count, $counted_list] );
1214            
1215 0           EVENT:
1216             $event .= "\tascii_secs:\n" . $ascii_secs;
1217 0           $event .= "\tSECS object:\n";
1218 0           $event .= Dumper(@secs_obj);
1219 0           $event .= "\tSubroutine: Data::Secs2::transify $VERSION\n";
1220 0 0         if($options->{warnings} ) {
    0          
1221 0           warn($event);
1222             }
1223             elsif($options->{die}) {
1224 0           die($event);
1225             }
1226 0           $event;
1227             }
1228            
1229            
1230             1
1231            
1232             __END__