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__
|