line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
#! perl |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
package Palm::ListDB::Writer; |
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
# ListDB.pm -- Create databases for Palm List application. |
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
# Author : Johan Vromans |
8
|
|
|
|
|
|
|
# Created On : Sun Aug 31 20:18:31 2003 |
9
|
|
|
|
|
|
|
# Last Modified By: Johan Vromans |
10
|
|
|
|
|
|
|
# Last Modified On: Tue Apr 11 12:01:23 2017 |
11
|
|
|
|
|
|
|
# Update Count : 87 |
12
|
|
|
|
|
|
|
# Status : Unknown, Use with caution! |
13
|
|
|
|
|
|
|
|
14
|
1
|
|
|
1
|
|
14448
|
use strict; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
24
|
|
15
|
1
|
|
|
1
|
|
4
|
use warnings; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
29
|
|
16
|
1
|
|
|
1
|
|
4
|
use Carp; |
|
1
|
|
|
|
|
4
|
|
|
1
|
|
|
|
|
803
|
|
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
our $VERSION = "1.13"; |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
=head1 NAME |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
Palm::ListDB::Writer - Create databases for Palm List application |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
=head1 SYNOPSIS |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
use Palm::ListDB::Writer; |
27
|
|
|
|
|
|
|
my $db = new Palm::ListDB::Writer |
28
|
|
|
|
|
|
|
"MyDataBase", |
29
|
|
|
|
|
|
|
"label1" => "Name", |
30
|
|
|
|
|
|
|
"label2" => "Address"); |
31
|
|
|
|
|
|
|
$db->add("Private", "Wife", "16 Localstreet, Netcity", "Some comments"); |
32
|
|
|
|
|
|
|
$db->add("Public", "John Doe", "1 Main St., Connecticut", "Blah blah"); |
33
|
|
|
|
|
|
|
$db->write("addr.pdb"); |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
=head1 ABSTRACT |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
Palm::ListDB::Writer creates databases for the Palm utility List. |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
=head1 DESCRIPTION |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
Palm::ListDB::Writer can be used to create databases for the Palm |
42
|
|
|
|
|
|
|
utility List, a simple but convenient database application. List is |
43
|
|
|
|
|
|
|
written by Andrew Low (roo@magma.ca, http://www.magma.ca/~roo). |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
List databases consist of a collection of records, each having two |
46
|
|
|
|
|
|
|
label fields and one note field (arbitrary data). |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
The basic usage is to create a Palm::ListDB::Writer object with |
49
|
|
|
|
|
|
|
attributes like the name of the database, the primary and secondary |
50
|
|
|
|
|
|
|
field labels, and then add records by calling its add() method. |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
The write() method writes the collected data out in the form of a Palm |
53
|
|
|
|
|
|
|
database. |
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
Limitations posed by the Palm operating system and/or the List |
56
|
|
|
|
|
|
|
application: database name - 31 characters; field names - 15 |
57
|
|
|
|
|
|
|
characters; category names - 15 characters; 15 categories excluding |
58
|
|
|
|
|
|
|
the default (Unfiled) catagory; field values - 63 characters; length |
59
|
|
|
|
|
|
|
of note data - 1023 characters. |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
This module is not related to L; the latter can also |
62
|
|
|
|
|
|
|
import Palm List databases, and requires some knowledge about Palm |
63
|
|
|
|
|
|
|
databases. |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
=cut |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
my @_atts = qw(cat truncate readonly private backup |
68
|
|
|
|
|
|
|
autocat label1 label2); |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
=head1 METHODS |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
=over 4 |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
=item new I, [ I ] |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
Default constructor for a new database object. |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
new() requires one argument, the name of the database. |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
Initial attributes for the database can be specified after the |
81
|
|
|
|
|
|
|
database name in the form of key => value pairs: |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
=over 4 |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
=item label1 |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
The name for the primary record field, max. 15 characters. |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
=item label2 |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
The name for the secondary record field, max. 15 characters. |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
=item cat |
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
An array reference with the names of the categories. Max. 15 |
96
|
|
|
|
|
|
|
categories are allowed, and category names must not exceed 15 |
97
|
|
|
|
|
|
|
characters in length. |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
=item autocat |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
If non-zero, new categories are automatically added when records are |
102
|
|
|
|
|
|
|
added. Defaults to true if no initial category names were supplied. |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
Additional methods can be added later with the add_cat() method. |
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
=item readonly |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
If true, the database will be readonly and cannot be modified by the |
109
|
|
|
|
|
|
|
List application. |
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
=item backup |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
If false, the database will not be backupped upon the next HotSync. |
114
|
|
|
|
|
|
|
Note that the List application may change this, for example when |
115
|
|
|
|
|
|
|
modifications are made. |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
=item private |
118
|
|
|
|
|
|
|
|
119
|
|
|
|
|
|
|
If true, the database is private and cannot be beamed. |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
=item truncate |
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
Controls truncation of names and fields that are too long. |
124
|
|
|
|
|
|
|
If zero, no truncation takes place (the program is terminated). |
125
|
|
|
|
|
|
|
If one, excess data for the record fields is truncated. |
126
|
|
|
|
|
|
|
If two, also truncates names for categories and fields. |
127
|
|
|
|
|
|
|
If three, also truncates the name of the database if needed. |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
=back |
130
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
=cut |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
sub new($;@) { |
134
|
1
|
|
|
1
|
1
|
812
|
my ($pkg, $name, %opts) = @_; |
135
|
1
|
|
|
|
|
11
|
my $self = |
136
|
|
|
|
|
|
|
{ name => $name, |
137
|
|
|
|
|
|
|
cat => [], |
138
|
|
|
|
|
|
|
_cat => {}, |
139
|
|
|
|
|
|
|
truncate => 0, |
140
|
|
|
|
|
|
|
readonly => 0, |
141
|
|
|
|
|
|
|
private => 0, |
142
|
|
|
|
|
|
|
backup => 1, |
143
|
|
|
|
|
|
|
autocat => undef, |
144
|
|
|
|
|
|
|
label1 => "Field1", |
145
|
|
|
|
|
|
|
label2 => "Field2", |
146
|
|
|
|
|
|
|
_data => [], |
147
|
|
|
|
|
|
|
}; |
148
|
1
|
|
|
|
|
1
|
bless($self, $pkg); |
149
|
|
|
|
|
|
|
|
150
|
1
|
|
|
|
|
5
|
$self->{name} = $self->_checklen("Database name", $name, 31, 2); |
151
|
|
|
|
|
|
|
|
152
|
1
|
|
|
|
|
2
|
foreach my $att ( @_atts ) { |
153
|
8
|
100
|
|
|
|
14
|
if ( exists($opts{$att}) ) { |
154
|
1
|
|
|
|
|
2
|
$self->{$att} = delete($opts{$att}); |
155
|
|
|
|
|
|
|
} |
156
|
|
|
|
|
|
|
} |
157
|
1
|
50
|
|
|
|
3
|
croak(__PACKAGE__.": Unknown constructor attributes: ". |
158
|
|
|
|
|
|
|
join(" ", sort(keys(%opts)))) if %opts; |
159
|
|
|
|
|
|
|
|
160
|
1
|
|
|
|
|
3
|
$self->{autocat} = @{$self->{cat}} ? 0 : 1 |
161
|
1
|
50
|
|
|
|
3
|
unless defined $self->{autocat}; |
|
|
50
|
|
|
|
|
|
162
|
1
|
|
|
|
|
2
|
unshift(@{$self->{cat}}, "Unfiled"); |
|
1
|
|
|
|
|
3
|
|
163
|
1
|
|
|
|
|
1
|
my @a = @{$self->{cat}}; |
|
1
|
|
|
|
|
2
|
|
164
|
1
|
|
|
|
|
2
|
$self->{cat} = []; |
165
|
1
|
|
|
|
|
1
|
foreach my $cat ( @a ) { |
166
|
4
|
|
|
|
|
6
|
$self->_addcat($cat); |
167
|
|
|
|
|
|
|
} |
168
|
1
|
|
|
|
|
3
|
$self->{label1} = $self->_checklen("Label1", $self->{label1}, 15, 1); |
169
|
1
|
|
|
|
|
2
|
$self->{label2} = $self->_checklen("Label2", $self->{label2}, 15, 1); |
170
|
1
|
|
|
|
|
7
|
$self->{ctime} = $self->{mtime} = $self->{btime} = time; |
171
|
1
|
|
|
|
|
2
|
$self; |
172
|
|
|
|
|
|
|
} |
173
|
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
sub _checklen { |
175
|
15
|
|
|
15
|
|
15
|
my ($self, $name, $value, $max, $lvl) = @_; |
176
|
15
|
50
|
|
|
|
22
|
if ( length($value) > $max ) { |
177
|
0
|
|
|
|
|
0
|
my $v = substr($value,0,30); |
178
|
0
|
|
|
|
|
0
|
$v =~ s/[^\040-\177]/./g; |
179
|
0
|
|
|
|
|
0
|
my $msg = __PACKAGE__.": $name (". |
180
|
|
|
|
|
|
|
$v.") too long (". |
181
|
|
|
|
|
|
|
length($value)." > $max)"; |
182
|
0
|
0
|
|
|
|
0
|
if ( $self->{truncate} > $lvl ) { |
183
|
0
|
|
|
|
|
0
|
warn("$msg, truncated\n"); |
184
|
0
|
|
|
|
|
0
|
substr($value, $max) = ""; |
185
|
|
|
|
|
|
|
} |
186
|
|
|
|
|
|
|
else { |
187
|
0
|
|
|
|
|
0
|
croak($msg); |
188
|
|
|
|
|
|
|
} |
189
|
|
|
|
|
|
|
} |
190
|
15
|
|
|
|
|
36
|
$value; |
191
|
|
|
|
|
|
|
} |
192
|
|
|
|
|
|
|
|
193
|
|
|
|
|
|
|
sub _addcat { |
194
|
6
|
|
|
6
|
|
6
|
my ($self, $value) = @_; |
195
|
6
|
|
|
|
|
7
|
$value = $self->_checklen("Category name", $value, 15, 1); |
196
|
|
|
|
|
|
|
return $self->{_cat}->{$value} |
197
|
6
|
50
|
|
|
|
9
|
if defined($self->{_cat}->{$value}); |
198
|
6
|
50
|
|
|
|
4
|
if ( @{$self->{cat}} == 16 ) { |
|
6
|
|
|
|
|
10
|
|
199
|
0
|
|
|
|
|
0
|
croak(__PACKAGE__.": Too many categories ($value)"); |
200
|
|
|
|
|
|
|
} |
201
|
6
|
|
|
|
|
4
|
push(@{$self->{cat}}, $value); |
|
6
|
|
|
|
|
7
|
|
202
|
6
|
|
|
|
|
3
|
$self->{_cat}->{$value} = @{$self->{cat}}; |
|
6
|
|
|
|
|
14
|
|
203
|
|
|
|
|
|
|
} |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
=item add I, I, I, I |
206
|
|
|
|
|
|
|
|
207
|
|
|
|
|
|
|
As the name suggests, add() adds records to the database. |
208
|
|
|
|
|
|
|
|
209
|
|
|
|
|
|
|
Add() takes exactly four arguments: the category for the record, its |
210
|
|
|
|
|
|
|
first field, its second field, and the note data. Fields may be left |
211
|
|
|
|
|
|
|
empty (or undefined), but not all of them. |
212
|
|
|
|
|
|
|
|
213
|
|
|
|
|
|
|
If the named category does not exists, and autocat is in effect, it is |
214
|
|
|
|
|
|
|
automatically added to the list of categories. |
215
|
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
Add() returns true if the record was successfully added. |
217
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
=cut |
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
sub add($$$$$) { |
221
|
2
|
|
|
2
|
1
|
3
|
my ($self, $cat, $f1, $f2, $note) = @_; |
222
|
|
|
|
|
|
|
|
223
|
2
|
100
|
|
|
|
7
|
if ( $self->{_cat}->{$cat} ) { |
|
|
50
|
|
|
|
|
|
224
|
1
|
|
|
|
|
3
|
$cat = $self->{_cat}->{$cat}; |
225
|
|
|
|
|
|
|
} |
226
|
|
|
|
|
|
|
elsif ( $self->{autocat} ) { |
227
|
1
|
|
|
|
|
2
|
$cat = $self->_addcat($cat); |
228
|
|
|
|
|
|
|
} |
229
|
|
|
|
|
|
|
else { |
230
|
0
|
|
|
|
|
0
|
carp(__PACKAGE__.": Unknown category ($cat)"); |
231
|
0
|
|
|
|
|
0
|
return 0; |
232
|
|
|
|
|
|
|
} |
233
|
2
|
0
|
33
|
|
|
8
|
if ( $f1 eq "" && $f2 eq "" && $note eq "" ) { |
|
|
|
33
|
|
|
|
|
234
|
0
|
|
|
|
|
0
|
carp(__PACKAGE__.": Record needs data"); |
235
|
0
|
|
|
|
|
0
|
return 0; |
236
|
|
|
|
|
|
|
} |
237
|
2
|
|
50
|
|
|
2
|
push(@{$self->{_data}}, |
|
2
|
|
50
|
|
|
8
|
|
|
|
|
50
|
|
|
|
|
238
|
|
|
|
|
|
|
[$cat, |
239
|
|
|
|
|
|
|
$self->_checklen("field1", $f1||"", 63, 1), |
240
|
|
|
|
|
|
|
$self->_checklen("field2", $f2||"", 63, 1), |
241
|
|
|
|
|
|
|
$self->_checklen("note", $note||"", 1023, 0)]); |
242
|
2
|
|
|
|
|
5
|
1; |
243
|
|
|
|
|
|
|
} |
244
|
|
|
|
|
|
|
|
245
|
|
|
|
|
|
|
=item add_cat I |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
Adds a new category. One parameter, the name of the category to be |
248
|
|
|
|
|
|
|
added. If the category already exists, nothing happens. |
249
|
|
|
|
|
|
|
|
250
|
|
|
|
|
|
|
=cut |
251
|
|
|
|
|
|
|
|
252
|
|
|
|
|
|
|
sub add_cat($$) { |
253
|
1
|
|
|
1
|
1
|
169
|
my ($self, $cat) = @_; |
254
|
1
|
|
|
|
|
2
|
my $catcode = $self->{_cat}->{$cat}; |
255
|
1
|
50
|
|
|
|
2
|
return $catcode if $catcode; |
256
|
1
|
|
|
|
|
2
|
$self->_addcat($cat); |
257
|
|
|
|
|
|
|
} |
258
|
|
|
|
|
|
|
|
259
|
|
|
|
|
|
|
=item categories |
260
|
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
Returns an array with the current set of categories. |
262
|
|
|
|
|
|
|
Note that this excludes the (default) 'Unfiled' category. |
263
|
|
|
|
|
|
|
|
264
|
|
|
|
|
|
|
=cut |
265
|
|
|
|
|
|
|
|
266
|
|
|
|
|
|
|
sub categories($) { |
267
|
1
|
|
|
1
|
1
|
2
|
my ($self) = @_; |
268
|
1
|
|
|
|
|
1
|
my @a = @{$self->{cat}}; |
|
1
|
|
|
|
|
3
|
|
269
|
1
|
|
|
|
|
2
|
shift(@a); |
270
|
1
|
|
|
|
|
5
|
@a; |
271
|
|
|
|
|
|
|
} |
272
|
|
|
|
|
|
|
|
273
|
|
|
|
|
|
|
=item write I |
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
Write() takes one argument: the file name for the database. |
276
|
|
|
|
|
|
|
|
277
|
|
|
|
|
|
|
Returns true if the database was successfully written. |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
=cut |
280
|
|
|
|
|
|
|
|
281
|
|
|
|
|
|
|
sub write($$) { |
282
|
1
|
|
|
1
|
1
|
3
|
my ($self, $file) = @_; |
283
|
1
|
50
|
|
|
|
14
|
unless ( @{$self->{_data}} ) { |
|
1
|
|
|
|
|
4
|
|
284
|
0
|
|
|
|
|
0
|
carp(__PACKAGE__.": No records to write to $file"); |
285
|
0
|
|
|
|
|
0
|
return 0; |
286
|
|
|
|
|
|
|
} |
287
|
|
|
|
|
|
|
|
288
|
|
|
|
|
|
|
# Based on information derived from code by Gustaf Naeser and |
289
|
|
|
|
|
|
|
# Darren Dunham. |
290
|
|
|
|
|
|
|
|
291
|
1
|
|
|
|
|
1
|
my $n_records = scalar(@{$self->{_data}}); |
|
1
|
|
|
|
|
2
|
|
292
|
1
|
|
|
|
|
2
|
my $dbname = $self->{name}; |
293
|
1
|
|
|
|
|
2
|
my $field1label = $self->{label1}; |
294
|
1
|
|
|
|
|
2
|
my $field2label = $self->{label2}; |
295
|
1
|
|
|
|
|
1
|
my $numcats = @{$self->{cat}}; |
|
1
|
|
|
|
|
1
|
|
296
|
|
|
|
|
|
|
|
297
|
|
|
|
|
|
|
# Pre-sort the records. This eliminates the need for List to resort, |
298
|
|
|
|
|
|
|
# which makes opening the database very fast. |
299
|
1
|
|
|
1
|
|
540
|
use locale; |
|
1
|
|
|
|
|
419
|
|
|
1
|
|
|
|
|
4
|
|
300
|
|
|
|
|
|
|
my @records = sort { |
301
|
1
|
50
|
33
|
|
|
9
|
lc($a->[1]) cmp lc($b->[1]) |
302
|
|
|
|
|
|
|
|| |
303
|
|
|
|
|
|
|
lc($a->[2]) cmp lc($b->[2]) |
304
|
|
|
|
|
|
|
|| |
305
|
|
|
|
|
|
|
$a->[0] <=> $b->[0] |
306
|
1
|
|
|
|
|
2
|
} @{$self->{_data}}; |
|
1
|
|
|
|
|
5
|
|
307
|
|
|
|
|
|
|
|
308
|
1
|
|
|
|
|
2
|
my $fh; |
309
|
1
|
50
|
|
|
|
78
|
open($fh, ">$file") |
310
|
|
|
|
|
|
|
|| croak(__PACKAGE__.": $file: $!"); |
311
|
1
|
|
|
|
|
3
|
binmode($fh); |
312
|
|
|
|
|
|
|
|
313
|
|
|
|
|
|
|
# Structure of the database |
314
|
|
|
|
|
|
|
# |
315
|
|
|
|
|
|
|
# - Database header (78 bytes) |
316
|
|
|
|
|
|
|
# - Index table ($n_records * 8 bytes + 0x8000 padding) |
317
|
|
|
|
|
|
|
# - Application info (512 bytes) |
318
|
|
|
|
|
|
|
# - Data (records) |
319
|
|
|
|
|
|
|
|
320
|
|
|
|
|
|
|
# The database header (78 bytes) |
321
|
|
|
|
|
|
|
# 32 bytes database name, nul filled, nul terminated |
322
|
|
|
|
|
|
|
# 2 bytes of attributes, set to 0x0008 (backup) |
323
|
|
|
|
|
|
|
# 2 bytes of version information, set to 0x0000 |
324
|
|
|
|
|
|
|
# 12 bytes dates (creation, modification, last backup; 4 bytes each) |
325
|
|
|
|
|
|
|
# 4 bytes modification number, set to 0x00000000 |
326
|
|
|
|
|
|
|
# 4 bytes offset to application info |
327
|
|
|
|
|
|
|
# 4 bytes offset to sort info (set to 0x00000000) |
328
|
|
|
|
|
|
|
# 4 bytes type = "DATA" |
329
|
|
|
|
|
|
|
# 4 bytes creator = "LSdb" |
330
|
|
|
|
|
|
|
# 4 bytes unique seed, set to 0x00000000 |
331
|
|
|
|
|
|
|
# 4 bytes next record list, set to 0x00000000 |
332
|
|
|
|
|
|
|
# 2 bytes number of records |
333
|
|
|
|
|
|
|
|
334
|
1
|
|
|
|
|
1
|
my $headerfmt = "Z32 n n NNN N N N A4 A4 N N n"; |
335
|
|
|
|
|
|
|
my $hdr = pack($headerfmt, |
336
|
|
|
|
|
|
|
$dbname, |
337
|
|
|
|
|
|
|
0 | ($self->{backup} ? 0x0008 : 0x0) |
338
|
|
|
|
|
|
|
| ($self->{private} ? 0x0040 : 0x0), |
339
|
|
|
|
|
|
|
0x0000, |
340
|
|
|
|
|
|
|
$self->{ctime}, |
341
|
|
|
|
|
|
|
$self->{mtime}, |
342
|
|
|
|
|
|
|
$self->{btime}, |
343
|
1
|
50
|
|
|
|
16
|
0, |
|
|
50
|
|
|
|
|
|
344
|
|
|
|
|
|
|
78 + ($n_records * 8) + 2, |
345
|
|
|
|
|
|
|
0, |
346
|
|
|
|
|
|
|
"DATA", |
347
|
|
|
|
|
|
|
"LSdb", |
348
|
|
|
|
|
|
|
0, |
349
|
|
|
|
|
|
|
0, |
350
|
|
|
|
|
|
|
$n_records); |
351
|
1
|
50
|
|
|
|
3
|
croak(__PACKAGE__.": Header is ".length($hdr)." instead of 78") |
352
|
|
|
|
|
|
|
unless length($hdr) == 78; |
353
|
1
|
|
|
|
|
8
|
print $fh ($hdr); |
354
|
|
|
|
|
|
|
|
355
|
|
|
|
|
|
|
# Index table (8 bytes/record + 0x8000 padding) |
356
|
|
|
|
|
|
|
# 4 bytes offset to record data |
357
|
|
|
|
|
|
|
# 1 byte attributes = index of the category the record belongs to |
358
|
|
|
|
|
|
|
# 3 bytes unique id = index of the record (counting from 0) |
359
|
|
|
|
|
|
|
|
360
|
1
|
|
|
|
|
2
|
my $offset = (78 + ($n_records * 8) + 512 + 2); |
361
|
1
|
|
|
|
|
2
|
my $index = 0; |
362
|
1
|
|
|
|
|
2
|
foreach my $record ( @records ) { |
363
|
2
|
|
|
|
|
5
|
my ($cat, $field1, $field2, $note, $len) = @$record; |
364
|
2
|
|
|
|
|
1
|
$len = 3; |
365
|
2
|
50
|
|
|
|
5
|
$len += length($field1)+1 if $field1 ne ""; |
366
|
2
|
50
|
|
|
|
5
|
$len += length($field2)+1 if $field2 ne ""; |
367
|
2
|
50
|
|
|
|
6
|
$len += length($note)+1 if $note ne ""; |
368
|
2
|
50
|
|
|
|
4
|
$len++ if $len == 3; |
369
|
2
|
|
|
|
|
5
|
print $fh (pack("NN", $offset, $index | (($cat-1) << 24))); |
370
|
2
|
|
|
|
|
2
|
$offset += $len; |
371
|
2
|
|
|
|
|
2
|
$index++; |
372
|
|
|
|
|
|
|
} |
373
|
|
|
|
|
|
|
# Padding. |
374
|
1
|
|
|
|
|
2
|
print $fh (pack("n", 0x8000)); |
375
|
|
|
|
|
|
|
|
376
|
|
|
|
|
|
|
# Application info (size = 512 bytes) |
377
|
|
|
|
|
|
|
# 2 bytes renamed categories, set to 0x000e |
378
|
|
|
|
|
|
|
# 16 * 16 bytes of category labels, nul padded, nul terminated |
379
|
|
|
|
|
|
|
# 16 * 1 byte of category unique ids |
380
|
|
|
|
|
|
|
# (first (Unfiled)) = 0x00 |
381
|
|
|
|
|
|
|
# (rest) index + 0x0f if used, index otherwise |
382
|
|
|
|
|
|
|
# E.g. 00 10 11 12 14 15 06 07 08 09 0a 0b 0c 0d 0e 0f |
383
|
|
|
|
|
|
|
# 1 byte last unique id, set to the highest category unique id |
384
|
|
|
|
|
|
|
# 1 byte display style, set to 0x00 (no resort, field1/field2) |
385
|
|
|
|
|
|
|
# 1 byte write protect, 0x00 for off, 0x01 for on |
386
|
|
|
|
|
|
|
# 1 byte last category, 0xff for all, 0x00 for Unfiled |
387
|
|
|
|
|
|
|
# (The category view the DB opens with) |
388
|
|
|
|
|
|
|
# 16 bytes custom field 1 label, nul padded, nul terminated |
389
|
|
|
|
|
|
|
# 16 bytes custom field 2 label, as above |
390
|
|
|
|
|
|
|
# 202 bytes padding to make the size 512 bytes |
391
|
|
|
|
|
|
|
|
392
|
|
|
|
|
|
|
# Note: repeat groups ups the requirement to 5.8. Not needed. |
393
|
1
|
|
|
|
|
1
|
my $appinfofmt = "n ".("Z16" x 16)." C16 C C C C Z16Z16 x202"; |
394
|
|
|
|
|
|
|
my $appinfo = pack($appinfofmt, |
395
|
|
|
|
|
|
|
0x000e, |
396
|
16
|
100
|
|
|
|
34
|
(map { $self->{cat}->[$_] || '' } 0..15), |
397
|
16
|
100
|
100
|
|
|
51
|
(map { $_ && $_ < $numcats ? $_ + 0x0f : $_ } 0..15), |
398
|
|
|
|
|
|
|
$numcats - 1 + 0x0f, |
399
|
|
|
|
|
|
|
0x00, # no resort, field1/field2 |
400
|
|
|
|
|
|
|
# 0x80, # force resort, field1/field2 |
401
|
|
|
|
|
|
|
# 0x81, # force resort, field2/field1 |
402
|
1
|
50
|
|
|
|
3
|
$self->{readonly} ? 0x01 : 0x00, |
403
|
|
|
|
|
|
|
0xff, # last category -- all |
404
|
|
|
|
|
|
|
$field1label, $field2label); |
405
|
1
|
50
|
|
|
|
5
|
croak(__PACKAGE__.": AppInfo is ".length($appinfo)." instead of 512") |
406
|
|
|
|
|
|
|
unless length($appinfo) == 512; |
407
|
1
|
|
|
|
|
2
|
print $fh ($appinfo); |
408
|
|
|
|
|
|
|
|
409
|
|
|
|
|
|
|
# Records |
410
|
|
|
|
|
|
|
# 1 byte offset to field 1, 0 if no data in field |
411
|
|
|
|
|
|
|
# 1 byte offset to field 2, 0 if no data in field |
412
|
|
|
|
|
|
|
# 1 byte offset to note, 0 if no data in field |
413
|
|
|
|
|
|
|
# up to 3 0x00 terminated fields of max length 63, 63, 1023 |
414
|
|
|
|
|
|
|
# If no fields, then a nul pad is necessary (though this will never |
415
|
|
|
|
|
|
|
# be the case since we disallow that). |
416
|
|
|
|
|
|
|
|
417
|
1
|
|
|
|
|
3
|
foreach my $record ( @records ) { |
418
|
2
|
|
|
|
|
3
|
my ($cat, $field1, $field2, $note) = @$record; |
419
|
2
|
|
|
|
|
3
|
$offset = 3; |
420
|
2
|
|
|
|
|
3
|
foreach ( $field1, $field2, $note ) { |
421
|
6
|
|
|
|
|
3
|
my $len = length($_); |
422
|
6
|
50
|
|
|
|
6
|
if ( $len ) { |
423
|
6
|
|
|
|
|
7
|
print $fh (pack("C", $offset)); |
424
|
6
|
|
|
|
|
8
|
$offset += $len + 1; |
425
|
|
|
|
|
|
|
} |
426
|
|
|
|
|
|
|
else { |
427
|
0
|
|
|
|
|
0
|
print $fh (pack("C", 0)); |
428
|
|
|
|
|
|
|
} |
429
|
|
|
|
|
|
|
} |
430
|
2
|
|
|
|
|
1
|
foreach ( $field1, $field2, $note ) { |
431
|
6
|
50
|
|
|
|
8
|
next unless length($_); |
432
|
6
|
|
|
|
|
8
|
print $fh (pack("a*x", $_)); |
433
|
|
|
|
|
|
|
} |
434
|
|
|
|
|
|
|
} |
435
|
|
|
|
|
|
|
|
436
|
|
|
|
|
|
|
# Everything has been written |
437
|
1
|
|
|
|
|
43
|
close($fh); |
438
|
|
|
|
|
|
|
|
439
|
1
|
|
|
|
|
4
|
1; |
440
|
|
|
|
|
|
|
} |
441
|
|
|
|
|
|
|
|
442
|
|
|
|
|
|
|
1; |
443
|
|
|
|
|
|
|
__END__ |