File Coverage

blib/lib/EBook/MOBI/MobiPerl/Palm/PDB.pm
Criterion Covered Total %
statement 128 390 32.8
branch 44 204 21.5
condition 16 59 27.1
subroutine 8 19 42.1
pod 10 11 90.9
total 206 683 30.1


line stmt bran cond sub pod time code
1             # PDB.pm
2             #
3             # Perl module for reading and writing Palm databases (both PDB and PRC).
4             #
5             # Copyright (C) 1999, 2000, Andrew Arensburger.
6             # You may distribute this file under the terms of the Artistic
7             # License, as specified in the README file.
8             #
9             # $Id: PDB.pm,v 1.29 2002/11/03 16:43:16 azummo Exp $
10              
11             # A Palm database file (either .pdb or .prc) has the following overall
12             # structure:
13             # Header
14             # Index header
15             # Record/resource index
16             # Two NUL(?) bytes
17             # Optional AppInfo block
18             # Optional sort block
19             # Records/resources
20             # See http://www.palmos.com/dev/tech/docs/fileformats.zip
21             # for details.
22              
23 9     9   46 use strict;
  9         18  
  9         714  
24             package EBook::MOBI::MobiPerl::Palm::PDB;
25 9     9   53 use vars qw( $VERSION %PDBHandlers %PRCHandlers );
  9         14  
  9         55339  
26              
27             # One liner, to allow MakeMaker to work.
28             $VERSION = do { my @r = (q$Revision: 1.29 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
29              
30             =head1 NAME
31              
32             Palm::PDB - Parse Palm database files.
33              
34             =head1 SYNOPSIS
35              
36             use Palm::PDB;
37             use SomeHelperClass;
38              
39             $pdb = new Palm::PDB;
40             $pdb->Load("myfile.pdb");
41              
42             # Manipulate records in $pdb
43              
44             $pdb->Write("myotherfile.pdb");
45              
46             (Note: yes, you do want to use C, even if you're dealing
47             with some other type of database. $pdb will be reblessed to the
48             appropriate type by C<$pdb-ELoad>.)
49              
50             =head1 DESCRIPTION
51              
52             The Palm::PDB module provides a framework for reading and writing
53             database files for use on PalmOS devices such as the PalmPilot. It can
54             read and write both Palm Database (C<.pdb>) and Palm Resource
55             (C<.prc>) files.
56              
57             By itself, the PDB module is not terribly useful; it is intended to be
58             used in conjunction with supplemental modules for specific types of
59             databases, such as Palm::Raw or Palm::Memo.
60              
61             The Palm::PDB module encapsulates the common work of parsing the
62             structure of a Palm database. The L function reads the file,
63             then passes the individual chunks (header, records, etc.) to
64             application-specific functions for processing. Similarly, the
65             L function calls application-specific functions to get the
66             individual chunks, then writes them to a file.
67              
68             =head1 METHODS
69              
70             =cut
71              
72             my $EPOCH_1904 = 2082844800; # Difference between Palm's
73             # epoch (Jan. 1, 1904) and
74             # Unix's epoch (Jan. 1, 1970),
75             # in seconds.
76             my $HeaderLen = 32+2+2+(9*4); # Size of database header
77             my $RecIndexHeaderLen = 6; # Size of record index header
78             my $IndexRecLen = 8; # Length of record index entry
79             my $IndexRsrcLen = 10; # Length of resource index entry
80              
81             %PDBHandlers = (); # Record handler map
82             %PRCHandlers = (); # Resource handler map
83              
84             =head2 new
85              
86             $new = new Palm::PDB();
87              
88             Creates a new PDB. $new is a reference to an anonymous hash. Some of
89             its elements have special significance. See L.
90              
91             =cut
92              
93             sub new
94             {
95 3     3 1 6 my $class = shift;
96 3         7 my $params = shift;
97              
98 3         6 my $self = {};
99              
100              
101             # Initialize the PDB. These values are just defaults, of course.
102 3   50     33 $self->{'name'} = $params->{'name'} || "";
103 3   50     21 $self->{'attributes'} = $params->{'attributes'} || {};
104 3   50     22 $self->{'version'} = $params->{'version'} || 0;
105              
106 3         31 my $now = time;
107              
108 3   33     21 $self->{'ctime'} = $params->{'ctime'} || $now;
109 3   33     20 $self->{'mtime'} = $params->{'mtime'} || $now;
110 3   33     41 $self->{'baktime'} = $params->{'baktime'} || -$EPOCH_1904;
111              
112 3   50     17 $self->{'modnum'} = $params->{'modnum'} || 0;
113 3   50     25 $self->{'type'} = $params->{'type'} || "\0\0\0\0";
114 3   50     20 $self->{'creator'} = $params->{'creator'} || "\0\0\0\0";
115 3   50     16 $self->{'uniqueIDseed'} = $params->{'uniqueIDseed'} || 0;
116              
117 3         10 $self->{"2NULs"} = "\0\0";
118              
119 3         10 bless $self, $class;
120 3         13 return $self;
121             }
122              
123             =head2 RegisterPDBHandlers
124              
125             &Palm::PDB::RegisterPDBHandlers("classname", typespec...);
126              
127             Typically:
128              
129             &Palm::PDB::RegisterPDBHandlers(__PACKAGE__,
130             [ "FooB", "DATA" ],
131             );
132              
133             The $pdb->L method acts as a virtual constructor. When
134             it reads the header of a C<.pdb> file, it looks up the file's creator
135             and type in a set of tables, and reblesses $pdb into a class capable
136             of parsing the application-specific parts of the file (AppInfo block,
137             records, etc.)
138              
139             RegisterPDBHandlers() adds entries to these tables; it says that any
140             file whose creator and/or type match any of the Is (there
141             may be several) should be reblessed into the class I.
142              
143             Note that RegisterPDBHandlers() applies only to record databases
144             (C<.pdb> files). For resource databases, see
145             L.
146              
147             RegisterPDBHandlers() is typically called in the import() function of
148             a helper class. In this case, the class is registering itself, and it
149             is simplest just to use C<__PACKAGE__> for the package name:
150              
151             package PalmFoo;
152             use Palm::PDB;
153              
154             sub import
155             {
156             &Palm::PDB::RegisterPDBHandlers(__PACKAGE__,
157             [ "FooZ", "DATA" ]
158             );
159             }
160              
161             A I can be either a string, or an anonymous array with two
162             elements. If it is an anonymous array, then the first element is the
163             file's creator; the second element is its type. If a I is a
164             string, it is equivalent to specifying that string as the database's
165             creator, and a wildcard as its type.
166              
167             The creator and type should be either four-character strings, or the
168             empty string. An empty string represents a wildcard. Thus:
169              
170             &Palm::PDB::RegisterPDBHandlers("MyClass",
171             [ "fOOf", "DATA" ],
172             [ "BarB", "" ],
173             [ "", "BazQ" ],
174             "Fred"
175             );
176              
177             Class MyClass will handle:
178              
179             =over 4
180              
181             =item Z<>
182              
183             Databases whose creator is C and whose type is C.
184              
185             =item Z<>
186              
187             Databases whose creator is C, of any type.
188              
189             =item Z<>
190              
191             Databases with any creator whose type is C.
192              
193             =item Z<>
194              
195             Databases whose creator is C, of any type.
196              
197             =back
198              
199             =for html
200            
201              
202             =cut
203             #' <-- For Emacs.
204              
205             sub RegisterPDBHandlers
206             {
207 18     18 1 36 my $handler = shift; # Name of class that'll handle
208             # these databases
209 18         35 my @types = @_;
210 18         29 my $item;
211              
212 18         37 foreach $item (@types)
213             {
214 18 50       70 if (ref($item) eq "ARRAY")
215             {
216 18         115 $PDBHandlers{$item->[0]}{$item->[1]} = $handler;
217             } else {
218 0         0 $PDBHandlers{$item}{""} = $handler;
219             }
220             }
221             }
222              
223             =head2 RegisterPRCHandlers
224              
225             &Palm::PDB::RegisterPRCHandlers("classname", typespec...);
226              
227             Typically:
228              
229             &Palm::PDB::RegisterPRCHandlers(__PACKAGE__,
230             [ "FooZ", "CODE" ],
231             );
232              
233             RegisterPRCHandlers() is similar to
234             L, but specifies a class
235             to handle resource database (C<.prc>) files.
236              
237             A class for parsing applications should begin with:
238              
239             package PalmApps;
240             use Palm::PDB;
241              
242             sub import
243             {
244             &Palm::PDB::RegisterPRCHandlers(__PACKAGE__,
245             [ "", "appl" ]
246             );
247             }
248              
249             =cut
250              
251             sub RegisterPRCHandlers
252             {
253 18     18 1 36 my $handler = shift; # Name of class that'll handle
254             # these databases
255 18         32 my @types = @_;
256 18         26 my $item;
257              
258 18         34 foreach $item (@types)
259             {
260 18 50       57 if (ref($item) eq "ARRAY")
261             {
262 18         283 $PRCHandlers{$item->[0]}{$item->[1]} = $handler;
263             } else {
264 0         0 $PRCHandlers{$item}{""} = $handler;
265             }
266             }
267             }
268              
269             =head2 Load
270              
271             $pdb->Load("filename");
272              
273             Reads the file F, parses it, reblesses $pdb to the
274             appropriate class, and invokes appropriate methods to parse the
275             application-specific parts of the database (see L).
276              
277             Load() uses the Is given to RegisterPDBHandlers() and
278             RegisterPRCHandlers() when deciding how to rebless $pdb. For record
279             databases, it uses the Is passed to RegisterPDBHandlers(),
280             and for resource databases, it uses the Is passed to
281             RegisterPRCHandlers().
282              
283             Load() looks for matching Is in the following order, from
284             most to least specific:
285              
286             =over 4
287              
288             =item 1
289              
290             A I that specifies both the database's creator and its type
291             exactly.
292              
293             =item 2
294              
295             A I that specifies the database's type and has a wildcard
296             for the creator (this is rarely used).
297              
298             =item 3
299              
300             A I that specifies the database's creator and has a wildcard
301             for the type.
302              
303             =item 4
304              
305             A I that has wildcards for both the creator and type.
306              
307             =back
308              
309             =for html
310            
311              
312             Thus, if the database has creator "FooZ" and type "DATA", Load() will
313             first look for "FooZ"/"DATA", then ""/"DATA", then "FooZ"/"", and
314             finally will fall back on ""/"" (the universal default).
315              
316             After Load() returns, $pdb may contain the following fields:
317              
318             =over
319              
320             =item $pdb-E{Z<>"name"Z<>}
321              
322             The name of the database.
323              
324             =item $pdb-E{Z<>"attributes"Z<>}{Z<>"ResDB"Z<>}
325              
326             =item $pdb-E{Z<>"attributes"Z<>}{Z<>"ReadOnly"Z<>}
327              
328             =item $pdb-E{Z<>"attributes"Z<>}{Z<>"AppInfoDirty"Z<>}
329              
330             =item $pdb-E{Z<>"attributes"Z<>}{Z<>"Backup"Z<>}
331              
332             =item $pdb-E{Z<>"attributes"Z<>}{Z<>"OKToInstallNewer"Z<>}
333              
334             =item $pdb-E{Z<>"attributes"Z<>}{Z<>"ResetAfterInstall"Z<>}
335              
336             =item $pdb-E{Z<>"attributes"Z<>}{Z<>"CopyPrevention"Z<>}
337              
338             =item $pdb-E{Z<>"attributes"Z<>}{Z<>"Stream"Z<>}
339              
340             =item $pdb-E{Z<>"attributes"Z<>}{Z<>"Hidden"Z<>}
341              
342             =item $pdb-E{Z<>"attributes"Z<>}{Z<>"LaunchableData"Z<>}
343              
344             =item $pdb-E{Z<>"attributes"Z<>}{Z<>"Recyclable"Z<>}
345              
346             =item $pdb-E{Z<>"attributes"Z<>}{Z<>"Bundle"Z<>}
347              
348             =item $pdb-E{Z<>"attributes"Z<>}{Z<>"Open"Z<>}
349              
350             These are the attribute flags from the database header. Each is true
351             iff the corresponding flag is set.
352              
353             The "LaunchableData" attribute is set on PQAs.
354              
355             =item $pdb-E{Z<>"version"Z<>}
356              
357             The database's version number. An integer.
358              
359             =item $pdb-E{Z<>"ctime"Z<>}
360              
361             =item $pdb-E{Z<>"mtime"Z<>}
362              
363             =item $pdb-E{Z<>"baktime"Z<>}
364              
365             The database's creation time, last modification time, and time of last
366             backup, in Unix C format (seconds since Jan. 1, 1970).
367              
368             =item $pdb-E{Z<>"modnum"Z<>}
369              
370             The database's modification number. An integer.
371              
372             =item $pdb-E{Z<>"type"Z<>}
373              
374             The database's type. A four-character string.
375              
376             =item $pdb-E{Z<>"creator"Z<>}
377              
378             The database's creator. A four-character string.
379              
380             =item $pdb-E{Z<>"uniqueIDseed"Z<>}
381              
382             The database's unique ID seed. An integer.
383              
384             =item $pdb-E{Z<>"2NULs"Z<>}
385              
386             The two NUL bytes that appear after the record index and the AppInfo
387             block. Included here because every once in a long while, they are not
388             NULs, for some reason.
389              
390             =item $pdb-E{Z<>"appinfo"Z<>}
391              
392             The AppInfo block, as returned by the $pdb->ParseAppInfoBlock() helper
393             method.
394              
395             =item $pdb-E{Z<>"sort"Z<>}
396              
397             The sort block, as returned by the $pdb->ParseSortBlock() helper
398             method.
399              
400             =item @{$pdb-E{Z<>"records"Z<>}}
401              
402             The list of records in the database, as returned by the
403             $pdb->ParseRecord() helper method. Resource databases do not have
404             this.
405              
406             =item @{$pdb-E{Z<>"resources"Z<>}}
407              
408             The list of resources in the database, as returned by the
409             $pdb->ParseResource() helper method. Record databases do not have
410             this.
411              
412             =back
413              
414             All of these fields may be set by hand, but should conform to the
415             format given above.
416              
417             =for html
418            
419              
420             =cut
421             #'
422              
423             # Load
424             sub Load
425             {
426 0     0 1 0 my $self = shift;
427 0         0 my $fname = shift; # Filename to read from
428 0         0 my $buf; # Buffer into which to read stuff
429              
430             # Open database file
431 0 0       0 open PDB, "< $fname" or die "Can't open \"$fname\": $!\n";
432 0         0 binmode PDB; # Read as binary file under MS-DOS
433              
434             # Get the size of the file. It'll be useful later
435 0         0 seek PDB, 0, 2; # 2 == SEEK_END. Seek to the end.
436 0         0 $self->{_size} = tell PDB;
437 0         0 seek PDB, 0, 0; # 0 == SEEK_START. Rewind to the beginning.
438              
439             # Read header
440 0         0 my $name;
441             my $attributes;
442 0         0 my $version;
443 0         0 my $ctime;
444 0         0 my $mtime;
445 0         0 my $baktime;
446 0         0 my $modnum;
447 0         0 my $appinfo_offset;
448 0         0 my $sort_offset;
449 0         0 my $type;
450 0         0 my $creator;
451 0         0 my $uniqueIDseed;
452              
453 0         0 read PDB, $buf, $HeaderLen; # Read the PDB header
454              
455             # Split header into its component fields
456 0         0 ($name, $attributes, $version, $ctime, $mtime, $baktime,
457             $modnum, $appinfo_offset, $sort_offset, $type, $creator,
458             $uniqueIDseed) =
459             unpack "a32 n n N N N N N N a4 a4 N", $buf;
460              
461 0         0 ($self->{name} = $name) =~ s/\0.*$//;
462 0 0       0 $self->{attributes}{resource} = 1 if $attributes & 0x0001;
463 0 0       0 $self->{attributes}{"read-only"} = 1 if $attributes & 0x0002;
464 0 0       0 $self->{attributes}{"AppInfo dirty"} = 1 if $attributes & 0x0004;
465 0 0       0 $self->{attributes}{backup} = 1 if $attributes & 0x0008;
466 0 0       0 $self->{attributes}{"OK newer"} = 1 if $attributes & 0x0010;
467 0 0       0 $self->{attributes}{reset} = 1 if $attributes & 0x0020;
468 0 0       0 $self->{attributes}{open} = 1 if $attributes & 0x8000;
469 0 0       0 $self->{attributes}{launchable} = 1 if $attributes & 0x0200;
470              
471             # Attribute names as of PalmOS 5.0 ( see /Core/System/DataMgr.h )
472              
473 0 0       0 $self->{'attributes'}{'ResDB'} = 1 if $attributes & 0x0001;
474 0 0       0 $self->{'attributes'}{'ReadOnly'} = 1 if $attributes & 0x0002;
475 0 0       0 $self->{'attributes'}{'AppInfoDirty'} = 1 if $attributes & 0x0004;
476 0 0       0 $self->{'attributes'}{'Backup'} = 1 if $attributes & 0x0008;
477 0 0       0 $self->{'attributes'}{'OKToInstallNewer'} = 1 if $attributes & 0x0010;
478 0 0       0 $self->{'attributes'}{'ResetAfterInstall'} = 1 if $attributes & 0x0020;
479 0 0       0 $self->{'attributes'}{'CopyPrevention'} = 1 if $attributes & 0x0040;
480 0 0       0 $self->{'attributes'}{'Stream'} = 1 if $attributes & 0x0080;
481 0 0       0 $self->{'attributes'}{'Hidden'} = 1 if $attributes & 0x0100;
482 0 0       0 $self->{'attributes'}{'LaunchableData'} = 1 if $attributes & 0x0200;
483 0 0       0 $self->{'attributes'}{'Recyclable'} = 1 if $attributes & 0x0400;
484 0 0       0 $self->{'attributes'}{'Bundle'} = 1 if $attributes & 0x0800;
485 0 0       0 $self->{'attributes'}{'Open'} = 1 if $attributes & 0x8000;
486              
487              
488 0         0 $self->{version} = $version;
489 0         0 $self->{ctime} = $ctime - $EPOCH_1904;
490 0         0 $self->{mtime} = $mtime - $EPOCH_1904;
491 0         0 $self->{baktime} = $baktime - $EPOCH_1904;
492 0         0 $self->{modnum} = $modnum;
493             # _appinfo_offset and _sort_offset are private fields
494 0         0 $self->{_appinfo_offset} = $appinfo_offset;
495 0         0 $self->{_sort_offset} = $sort_offset;
496 0         0 $self->{type} = $type;
497 0         0 $self->{creator} = $creator;
498 0         0 $self->{uniqueIDseed} = $uniqueIDseed;
499              
500             # Rebless this PDB object, depending on its type and/or
501             # creator. This allows us to magically invoke the proper
502             # &Parse*() function on the various parts of the database.
503              
504             # Look for most specific handlers first, least specific ones
505             # last. That is, first look for a handler that deals
506             # specifically with this database's creator and type, then for
507             # one that deals with this database's creator and any type,
508             # and finally for one that deals with anything.
509              
510 0         0 my $handler;
511 0 0 0     0 if ($self->{attributes}{resource} || $self->{'attributes'}{'ResDB'})
512             {
513             # Look among resource handlers
514 0   0     0 $handler = $PRCHandlers{$self->{creator}}{$self->{type}} ||
515             $PRCHandlers{undef}{$self->{type}} ||
516             $PRCHandlers{$self->{creator}}{""} ||
517             $PRCHandlers{""}{""};
518             } else {
519             # Look among record handlers
520 0   0     0 $handler = $PDBHandlers{$self->{creator}}{$self->{type}} ||
521             $PDBHandlers{""}{$self->{type}} ||
522             $PDBHandlers{$self->{creator}}{""} ||
523             $PDBHandlers{""}{""};
524             }
525              
526 0 0       0 if (defined($handler))
527             {
528 0         0 bless $self, $handler;
529             } else {
530             # XXX - This should probably return 'undef' or something,
531             # rather than die.
532 0         0 die "No handler defined for creator \"$creator\", type \"$type\"\n";
533             }
534              
535             ## Read record/resource index
536             # Read index header
537 0         0 read PDB, $buf, $RecIndexHeaderLen;
538              
539 0         0 my $next_index;
540             my $numrecs;
541              
542 0         0 ($next_index, $numrecs) = unpack "N n", $buf;
543 0         0 $self->{_numrecs} = $numrecs;
544              
545             # Read the index itself
546 0 0 0     0 if ($self->{attributes}{resource} || $self->{'attributes'}{'ResDB'})
547             {
548 0         0 &_load_rsrc_index($self, \*PDB);
549             } else {
550 0         0 &_load_rec_index($self, \*PDB);
551             }
552              
553             # Read the two NUL bytes
554             # XXX - Actually, these are bogus. They don't appear in the
555             # spec. The Right Thing to do is to ignore them, and use the
556             # specified or calculated offsets, if they're sane. Sane ==
557             # appears later than the current position.
558             # read PDB, $buf, 2;
559             # $self->{"2NULs"} = $buf;
560              
561             # Read AppInfo block, if it exists
562 0 0       0 if ($self->{_appinfo_offset} != 0)
563             {
564 0         0 &_load_appinfo_block($self, \*PDB);
565             }
566              
567             # Read sort block, if it exists
568 0 0       0 if ($self->{_sort_offset} != 0)
569             {
570 0         0 &_load_sort_block($self, \*PDB);
571             }
572              
573             # Read record/resource list
574 0 0 0     0 if ($self->{attributes}{resource} || $self->{'attributes'}{'ResDB'})
575             {
576 0         0 &_load_resources($self, \*PDB);
577             } else {
578 0         0 &_load_records($self, \*PDB);
579             }
580              
581             # These keys were needed for parsing the file, but are not
582             # needed any longer. Delete them.
583 0         0 delete $self->{_index};
584 0         0 delete $self->{_numrecs};
585 0         0 delete $self->{_appinfo_offset};
586 0         0 delete $self->{_sort_offset};
587 0         0 delete $self->{_size};
588              
589 0         0 close PDB;
590             }
591              
592             # _load_rec_index
593             # Private function. Read the record index, for a record database
594             sub _load_rec_index
595             {
596 0     0   0 my $pdb = shift;
597 0         0 my $fh = shift; # Input file handle
598 0         0 my $i;
599 0         0 my $lastoffset = 0;
600              
601             # Read each record index entry in turn
602 0         0 for ($i = 0; $i < $pdb->{_numrecs}; $i++)
603             {
604 0         0 my $buf; # Input buffer
605              
606             # Read the next record index entry
607             my $offset;
608 0         0 my $attributes;
609 0         0 my @id; # Raw ID
610 0         0 my $id; # Numerical ID
611 0         0 my $entry = {}; # Parsed index entry
612              
613 0         0 read $fh, $buf, $IndexRecLen;
614              
615             # The ID field is a bit weird: it's represented as 3
616             # bytes, but it's really a double word (long) value.
617              
618 0         0 ($offset, $attributes, @id) = unpack "N C C3", $buf;
619              
620 0 0       0 if ($offset == $lastoffset)
621             {
622 0         0 print STDERR "Record $i has same offset as previous one: $offset\n";
623             }
624              
625 0         0 $lastoffset = $offset;
626              
627 0         0 $entry->{offset} = $offset;
628              
629 0 0       0 $entry->{attributes}{expunged} = 1 if $attributes & 0x80;
630 0 0       0 $entry->{attributes}{dirty} = 1 if $attributes & 0x40;
631 0 0       0 $entry->{attributes}{deleted} = 1 if $attributes & 0x20;
632 0 0       0 $entry->{attributes}{private} = 1 if $attributes & 0x10;
633              
634             # Attribute names as of PalmOS 5.0 ( see /Core/System/DataMgr.h )
635              
636 0 0       0 $entry->{'attributes'}{'Delete'} = 1 if $attributes & 0x80;
637 0 0       0 $entry->{'attributes'}{'Dirty'} = 1 if $attributes & 0x40;
638 0 0       0 $entry->{'attributes'}{'Busy'} = 1 if $attributes & 0x20;
639 0 0       0 $entry->{'attributes'}{'Secret'} = 1 if $attributes & 0x10;
640              
641 0         0 $entry->{id} = ($id[0] << 16) |
642             ($id[1] << 8) |
643             $id[2];
644              
645             # The lower 4 bits of the attributes field are
646             # overloaded: If the record has been deleted and/or
647             # expunged, then bit 0x08 indicates whether the record
648             # should be archived. Otherwise (if it's an ordinary,
649             # non-deleted record), the lower 4 bits specify the
650             # category that the record belongs in.
651 0 0       0 if (($attributes & 0xa0) == 0)
652             {
653 0         0 $entry->{category} = $attributes & 0x0f;
654             } else {
655 0 0       0 $entry->{attributes}{archive} = 1
656             if $attributes & 0x08;
657             }
658              
659             # Put this information on a temporary array
660 0         0 push @{$pdb->{_index}}, $entry;
  0         0  
661             }
662             }
663              
664             # _load_rsrc_index
665             # Private function. Read the resource index, for a resource database
666             sub _load_rsrc_index
667             {
668 0     0   0 my $pdb = shift;
669 0         0 my $fh = shift; # Input file handle
670 0         0 my $i;
671              
672             # Read each resource index entry in turn
673 0         0 for ($i = 0; $i < $pdb->{_numrecs}; $i++)
674             {
675 0         0 my $buf; # Input buffer
676              
677             # Read the next resource index entry
678             my $type;
679 0         0 my $id;
680 0         0 my $offset;
681 0         0 my $entry = {}; # Parsed index entry
682              
683 0         0 read $fh, $buf, $IndexRsrcLen;
684              
685 0         0 ($type, $id, $offset) = unpack "a4 n N", $buf;
686              
687 0         0 $entry->{type} = $type;
688 0         0 $entry->{id} = $id;
689 0         0 $entry->{offset} = $offset;
690              
691 0         0 push @{$pdb->{_index}}, $entry;
  0         0  
692             }
693             }
694              
695             # _load_appinfo_block
696             # Private function. Read the AppInfo block
697             sub _load_appinfo_block
698             {
699 0     0   0 my $pdb = shift;
700 0         0 my $fh = shift; # Input file handle
701 0         0 my $len; # Length of AppInfo block
702             my $buf; # Input buffer
703              
704             # Sanity check: make sure we're positioned at the beginning of
705             # the AppInfo block
706 0 0       0 if (tell($fh) > $pdb->{_appinfo_offset})
707             {
708 0         0 die "Bad AppInfo offset: expected ",
709             sprintf("0x%08x", $pdb->{_appinfo_offset}),
710             ", but I'm at ",
711             tell($fh), "\n";
712             }
713              
714             # Seek to the right place, if necessary
715 0 0       0 if (tell($fh) != $pdb->{_appinfo_offset})
716             {
717 0         0 seek PDB, $pdb->{_appinfo_offset}, 0;
718             }
719              
720             # There's nothing that explicitly gives the size of the
721             # AppInfo block. Rather, it has to be inferred from the offset
722             # of the AppInfo block (previously recorded in
723             # $pdb->{_appinfo_offset}) and whatever's next in the file.
724             # That's either the sort block, the first data record, or the
725             # end of the file.
726              
727 0 0 0     0 if ($pdb->{_sort_offset})
    0          
728 0         0 {
729             # The next thing in the file is the sort block
730 0         0 $len = $pdb->{_sort_offset} - $pdb->{_appinfo_offset};
731             } elsif ((defined $pdb->{_index}) && @{$pdb->{_index}})
732             {
733             # There's no sort block; the next thing in the file is
734             # the first data record
735 0         0 $len = $pdb->{_index}[0]{offset} -
736             $pdb->{_appinfo_offset};
737             } else {
738             # There's no sort block and there are no records. The
739             # AppInfo block goes to the end of the file.
740 0         0 $len = $pdb->{_size} - $pdb->{_appinfo_offset};
741             }
742              
743             # Read the AppInfo block
744 0         0 read $fh, $buf, $len;
745              
746             # Tell the real class to parse the AppInfo block
747 0         0 $pdb->{appinfo} = $pdb->ParseAppInfoBlock($buf);
748             }
749              
750             # _load_sort_block
751             # Private function. Read the sort block.
752             sub _load_sort_block
753             {
754 0     0   0 my $pdb = shift;
755 0         0 my $fh = shift; # Input file handle
756 0         0 my $len; # Length of sort block
757             my $buf; # Input buffer
758              
759             # Sanity check: make sure we're positioned at the beginning of
760             # the sort block
761 0 0       0 if (tell($fh) > $pdb->{_sort_offset})
762             {
763 0         0 die "Bad sort block offset: expected ",
764             sprintf("0x%08x", $pdb->{_sort_offset}),
765             ", but I'm at ",
766             tell($fh), "\n";
767             }
768              
769             # Seek to the right place, if necessary
770 0 0       0 if (tell($fh) != $pdb->{_sort_offset})
771             {
772 0         0 seek PDB, $pdb->{_sort_offset}, 0;
773             }
774              
775             # There's nothing that explicitly gives the size of the sort
776             # block. Rather, it has to be inferred from the offset of the
777             # sort block (previously recorded in $pdb->{_sort_offset})
778             # and whatever's next in the file. That's either the first
779             # data record, or the end of the file.
780              
781 0 0       0 if (defined($pdb->{_index}))
782             {
783             # The next thing in the file is the first data record
784 0         0 $len = $pdb->{_index}[0]{offset} -
785             $pdb->{_sort_offset};
786             } else {
787             # There are no records. The sort block goes to the end
788             # of the file.
789 0         0 $len = $pdb->{_size} - $pdb->{_sort_offset};
790             }
791              
792             # Read the AppInfo block
793 0         0 read $fh, $buf, $len;
794              
795             # XXX - Check to see if the sort block has some predefined
796             # structure. If so, it might be a good idea to parse the sort
797             # block here.
798              
799             # Tell the real class to parse the sort block
800 0         0 $pdb->{sort} = $pdb->ParseSortBlock($buf);
801             }
802              
803             # _load_records
804             # Private function. Load the actual data records, for a record database
805             # (PDB)
806             sub _load_records
807             {
808 0     0   0 my $pdb = shift;
809 0         0 my $fh = shift; # Input file handle
810 0         0 my $i;
811              
812             # Read each record in turn
813 0         0 for ($i = 0; $i < $pdb->{_numrecs}; $i++)
814             {
815 0         0 my $len; # Length of record
816             my $buf; # Input buffer
817              
818             # Sanity check: make sure we're where we think we
819             # should be.
820 0 0       0 if (tell($fh) > $pdb->{_index}[$i]{offset})
821             {
822 0         0 die "Bad offset for record $i: expected ",
823             sprintf("0x%08x",
824             $pdb->{_index}[$i]{offset}),
825             " but it's at ",
826             sprintf("[0x%08x]", tell($fh)), "\n";
827             }
828              
829             # Seek to the right place, if necessary
830 0 0       0 if (tell($fh) != $pdb->{_index}[$i]{offset})
831             {
832 0         0 seek PDB, $pdb->{_index}[$i]{offset}, 0;
833             }
834              
835             # Compute the length of the record: the last record
836             # extends to the end of the file. The others extend to
837             # the beginning of the next record.
838 0 0       0 if ($i == $pdb->{_numrecs} - 1)
839             {
840             # This is the last record
841 0         0 $len = $pdb->{_size} -
842             $pdb->{_index}[$i]{offset};
843             } else {
844             # This is not the last record
845 0         0 $len = $pdb->{_index}[$i+1]{offset} -
846             $pdb->{_index}[$i]{offset};
847             }
848              
849             # Read the record
850 0         0 read $fh, $buf, $len;
851              
852             # Tell the real class to parse the record data. Pass
853             # &ParseRecord all of the information from the index,
854             # plus a "data" field with the raw record data.
855 0         0 my $record;
856              
857 0         0 $record = $pdb->ParseRecord(
858 0         0 %{$pdb->{_index}[$i]},
859             "data" => $buf,
860             );
861 0         0 push @{$pdb->{records}}, $record;
  0         0  
862             }
863             }
864              
865             # _load_resources
866             # Private function. Load the actual data resources, for a resource database
867             # (PRC)
868             sub _load_resources
869             {
870 0     0   0 my $pdb = shift;
871 0         0 my $fh = shift; # Input file handle
872 0         0 my $i;
873              
874             # Read each resource in turn
875 0         0 for ($i = 0; $i < $pdb->{_numrecs}; $i++)
876             {
877 0         0 my $len; # Length of record
878             my $buf; # Input buffer
879              
880             # Sanity check: make sure we're where we think we
881             # should be.
882 0 0       0 if (tell($fh) > $pdb->{_index}[$i]{offset})
883             {
884 0         0 die "Bad offset for resource $i: expected ",
885             sprintf("0x%08x",
886             $pdb->{_index}[$i]{offset}),
887             " but it's at ",
888             sprintf("0x%08x", tell($fh)), "\n";
889             }
890              
891             # Seek to the right place, if necessary
892 0 0       0 if (tell($fh) != $pdb->{_index}[$i]{offset})
893             {
894 0         0 seek PDB, $pdb->{_index}[$i]{offset}, 0;
895             }
896              
897             # Compute the length of the resource: the last
898             # resource extends to the end of the file. The others
899             # extend to the beginning of the next resource.
900 0 0       0 if ($i == $pdb->{_numrecs} - 1)
901             {
902             # This is the last resource
903 0         0 $len = $pdb->{_size} -
904             $pdb->{_index}[$i]{offset};
905             } else {
906             # This is not the last resource
907 0         0 $len = $pdb->{_index}[$i+1]{offset} -
908             $pdb->{_index}[$i]{offset};
909             }
910              
911             # Read the resource
912 0         0 read $fh, $buf, $len;
913              
914             # Tell the real class to parse the resource data. Pass
915             # &ParseResource all of the information from the
916             # index, plus a "data" field with the raw resource
917             # data.
918 0         0 my $resource;
919              
920 0         0 $resource = $pdb->ParseResource(
921 0         0 %{$pdb->{_index}[$i]},
922             "data" => $buf,
923             );
924 0         0 push @{$pdb->{resources}}, $resource;
  0         0  
925             }
926             }
927              
928             =head2 Write
929              
930             $pdb->Write("filename");
931              
932             Invokes methods in helper classes to get the application-specific
933             parts of the database, then writes the database to the file
934             I.
935              
936             Write() uses the following helper methods:
937              
938             =over
939              
940             =item Z<>
941              
942             PackAppInfoBlock()
943              
944             =item Z<>
945              
946             PackSortBlock()
947              
948             =item Z<>
949              
950             PackResource() or PackRecord()
951              
952             =back
953              
954             =for html
955            
956              
957             See also L.
958              
959             =cut
960             #' <-- For Emacs
961              
962             sub Write
963             {
964 3     3 1 6 my $self = shift;
965 3         7 my $fname = shift; # Output file name
966 3         6 my @record_data;
967              
968             # Open file
969 3 50       331 open my $OFILE, '>', $fname or die "Can't write to \"$fname\": $!\n";
970 3         10 binmode $OFILE; # Write as binary file under MS-DOS
971              
972             # Get AppInfo block
973 3         25 my $appinfo_block = $self->PackAppInfoBlock;
974              
975             # Get sort block
976 3         19 my $sort_block = $self->PackSortBlock;
977              
978 3         11 my $index_len;
979              
980             # Get records or resources
981 3 50 33     33 if ($self->{attributes}{resource} || $self->{'attributes'}{'ResDB'})
982             {
983             # Resource database
984 0         0 my $resource;
985              
986 0         0 foreach $resource (@{$self->{resources}})
  0         0  
987             {
988 0         0 my $type;
989             my $id;
990 0         0 my $data;
991              
992             # Get all the stuff that goes in the index, as
993             # well as the resource data.
994 0         0 $type = $resource->{type};
995 0         0 $id = $resource->{id};
996 0         0 $data = $self->PackResource($resource);
997              
998 0         0 push @record_data, [ $type, $id, $data ];
999             }
1000             # Figure out size of index
1001 0         0 $index_len = $RecIndexHeaderLen +
1002             ($#record_data + 1) * $IndexRsrcLen;
1003             } else {
1004 3         5 my $record;
1005              
1006 3         5 foreach $record (@{$self->{records}})
  3         8  
1007             {
1008 6         10 my $attributes;
1009             my $id;
1010 0         0 my $data;
1011              
1012             # XXX - Should probably check the length of this
1013             # record and not add it to the record if it's 0.
1014              
1015             # Get all the stuff that goes in the index, as
1016             # well as the record data.
1017 6         9 $attributes = 0;
1018 6 50 33     48 if ($record->{attributes}{expunged} ||
1019             $record->{attributes}{deleted})
1020             {
1021 0 0       0 $attributes |= 0x08
1022             if $record->{attributes}{archive};
1023             } else {
1024 6         93 $attributes = ($record->{category} & 0x0f);
1025             }
1026 6 50       20 $attributes |= 0x80
1027             if $record->{attributes}{expunged};
1028 6 50       20 $attributes |= 0x40
1029             if $record->{attributes}{dirty};
1030 6 50       24 $attributes |= 0x20
1031             if $record->{attributes}{deleted};
1032 6 50       16 $attributes |= 0x10
1033             if $record->{attributes}{private};
1034              
1035 6 50       16 $attributes |= 0x80 if $record->{'attributes'}{'Delete'};
1036 6 50       17 $attributes |= 0x40 if $record->{'attributes'}{'Dirty'};
1037 6 50       15 $attributes |= 0x20 if $record->{'attributes'}{'Busy'};
1038 6 50       17 $attributes |= 0x10 if $record->{'attributes'}{'Secret'};
1039              
1040 6         11 $id = $record->{id};
1041              
1042 6         29 $data = $self->PackRecord($record);
1043              
1044 6         22 push @record_data, [ $attributes, $id, $data ];
1045             }
1046             # Figure out size of index
1047 3         11 $index_len = $RecIndexHeaderLen +
1048             ($#record_data + 1) * $IndexRecLen;
1049             }
1050              
1051 3         4 my $header;
1052 3         5 my $attributes = 0x0000;
1053 3         6 my $appinfo_offset;
1054             my $sort_offset;
1055              
1056             # Build attributes field
1057 3 50       53 $attributes =
    50          
    50          
    50          
    50          
    50          
    50          
1058             ($self->{attributes}{resource} ? 0x0001 : 0) |
1059             ($self->{attributes}{"read-only"} ? 0x0002 : 0) |
1060             ($self->{attributes}{"AppInfo dirty"} ? 0x0004 : 0) |
1061             ($self->{attributes}{backup} ? 0x0008 : 0) |
1062             ($self->{attributes}{"OK newer"} ? 0x0010 : 0) |
1063             ($self->{attributes}{reset} ? 0x0020 : 0) |
1064             ($self->{attributes}{open} ? 0x8000 : 0);
1065              
1066 3 50       14 $attributes |= 0x0001 if $self->{'attributes'}{'ResDB'};
1067 3 50       9 $attributes |= 0x0002 if $self->{'attributes'}{'ReadOnly'};
1068 3 50       23 $attributes |= 0x0004 if $self->{'attributes'}{'AppInfoDirty'};
1069 3 50       11 $attributes |= 0x0008 if $self->{'attributes'}{'Backup'};
1070 3 50       10 $attributes |= 0x0010 if $self->{'attributes'}{'OKToInstallNewer'};
1071 3 50       17 $attributes |= 0x0020 if $self->{'attributes'}{'ResetAfterInstall'};
1072 3 50       13 $attributes |= 0x0040 if $self->{'attributes'}{'CopyPrevention'};
1073 3 50       17 $attributes |= 0x0080 if $self->{'attributes'}{'Stream'};
1074 3 50       12 $attributes |= 0x0100 if $self->{'attributes'}{'Hidden'};
1075 3 50       23 $attributes |= 0x0200 if $self->{'attributes'}{'LaunchableData'};
1076 3 50       10 $attributes |= 0x0400 if $self->{'attributes'}{'Recyclable'};
1077 3 50       10 $attributes |= 0x0800 if $self->{'attributes'}{'Bundle'};
1078 3 50       10 $attributes |= 0x8000 if $self->{'attributes'}{'Open'};
1079              
1080              
1081             # Calculate AppInfo block offset
1082 3 50 33     19 if ((!defined($appinfo_block)) || ($appinfo_block eq ""))
1083             {
1084             # There's no AppInfo block
1085 3         5 $appinfo_offset = 0;
1086             } else {
1087             # Offset of AppInfo block from start of file
1088 0         0 $appinfo_offset = $HeaderLen + $index_len + 2;
1089             }
1090              
1091             # Calculate sort block offset
1092 3 50 33     13 if ((!defined($sort_block)) || ($sort_block eq ""))
1093             {
1094             # There's no sort block
1095 3         7 $sort_offset = 0;
1096             } else {
1097             # Offset of sort block...
1098 0 0       0 if ($appinfo_offset == 0)
1099             {
1100             # ...from start of file
1101 0         0 $sort_offset = $HeaderLen + $index_len + 2;
1102             } else {
1103             # ...or just from start of AppInfo block
1104 0         0 $sort_offset = $appinfo_offset +
1105             length($appinfo_block);
1106             }
1107             }
1108              
1109             # Write header
1110 3         28 $header = pack "a32 n n N N N N N N a4 a4 N",
1111             $self->{name},
1112             $attributes,
1113             $self->{version},
1114             $self->{ctime} + $EPOCH_1904,
1115             $self->{mtime} + $EPOCH_1904,
1116             $self->{baktime} + $EPOCH_1904,
1117             $self->{modnum},
1118             $appinfo_offset,
1119             $sort_offset,
1120             $self->{type},
1121             $self->{creator},
1122             $self->{uniqueIDseed};
1123             ;
1124              
1125 3         184 print $OFILE "$header";
1126              
1127             # Write index header
1128 3         7 my $index_header;
1129              
1130 3         10 $index_header = pack "N n", 0, ($#record_data+1);
1131 3         7 print $OFILE "$index_header";
1132              
1133             # Write index
1134 3         5 my $rec_offset; # Offset of next record/resource
1135              
1136             # Calculate offset of first record/resource
1137 3 50       13 if ($sort_offset != 0)
    50          
1138             {
1139 0         0 $rec_offset = $sort_offset + length($sort_block);
1140             } elsif ($appinfo_offset != 0)
1141             {
1142 0         0 $rec_offset = $appinfo_offset + length($appinfo_block);
1143             } else {
1144 3         7 $rec_offset = $HeaderLen + $index_len + 2;
1145             }
1146              
1147 3 50 33     23 if ($self->{attributes}{resource} || $self->{'attributes'}{'ResDB'})
1148             {
1149             # Resource database
1150             # Record database
1151 0         0 my $rsrc_data;
1152              
1153 0         0 foreach $rsrc_data (@record_data)
1154             {
1155 0         0 my $type;
1156             my $id;
1157 0         0 my $data;
1158 0         0 my $index_data;
1159              
1160 0         0 ($type, $id, $data) = @{$rsrc_data};
  0         0  
1161 0         0 $index_data = pack "a4 n N",
1162             $type,
1163             $id,
1164             $rec_offset;
1165 0         0 print $OFILE "$index_data";
1166              
1167 0         0 $rec_offset += length($data);
1168             }
1169             } else {
1170             # Record database
1171 3         11 my $rec_data;
1172              
1173 3         5 foreach $rec_data (@record_data)
1174             {
1175 6         12 my $attributes;
1176             my $data;
1177 0         0 my $id;
1178 0         0 my $index_data;
1179              
1180             # XXX - Probably shouldn't write this record if
1181             # length($data) == 0
1182 6         8 ($attributes, $id, $data) = @{$rec_data};
  6         15  
1183              
1184 6 50       19 if (length($data) == 0)
1185             {
1186 0         0 warn printf("Write: Warning: record 0x%08x has length 0\n", $id)
1187             }
1188              
1189 6         23 $index_data = pack "N C C3",
1190             $rec_offset,
1191             $attributes,
1192             ($id >> 16) & 0xff,
1193             ($id >> 8) & 0xff,
1194             $id & 0xff;
1195 6         11 print $OFILE "$index_data";
1196              
1197 6         15 $rec_offset += length($data);
1198             }
1199             }
1200              
1201             # Write the two NULs
1202 3 50       17 if (length($self->{"2NULs"}) == 2)
1203             {
1204 3         9 print $OFILE $self->{"2NULs"};
1205             } else {
1206 0         0 print $OFILE "\0\0";
1207             }
1208              
1209             # Write AppInfo block
1210 3 50       17 print $OFILE $appinfo_block unless $appinfo_offset == 0;
1211              
1212             # Write sort block
1213 3 50       9 print $OFILE $sort_block unless $sort_offset == 0;
1214              
1215             # Write record/resource list
1216 3         6 my $record;
1217 3         10 foreach $record (@record_data)
1218             {
1219 6         9 my $data;
1220              
1221 6 50 33     35 if ($self->{attributes}{resource} || $self->{'attributes'}{'ResDB'})
1222             {
1223             # Resource database
1224 0         0 my $type;
1225             my $id;
1226              
1227 0         0 ($type, $id, $data) = @{$record};
  0         0  
1228             } else {
1229 6         8 my $attributes;
1230             my $id;
1231              
1232 6         9 ($attributes, $id, $data) = @{$record};
  6         24  
1233             }
1234 6         17 print $OFILE $data;
1235             }
1236              
1237 3         288 close $OFILE;
1238             }
1239              
1240             =head2 new_Record
1241              
1242             $record = Palm::PDB->new_Record();
1243             $record = new_Record Palm::PDB;
1244              
1245             Creates a new record, with the bare minimum needed:
1246              
1247             $record->{'category'}
1248             $record->{'attributes'}{'Dirty'}
1249             $record->{'id'}
1250              
1251             The ``Dirty'' attribute is originally set, since this function will
1252             usually be called to create records to be added to a database.
1253              
1254             C does B add the new record to a PDB. For that,
1255             you want C.
1256              
1257             =cut
1258              
1259             # PDB::new_Record()
1260             # Create a new, initialized record, and return a reference to it.
1261             # The record is initially marked as being dirty, since that's usually
1262             # the Right Thing.
1263             sub new_Record
1264             {
1265 6     6 1 12 my $classname = shift;
1266 6         10 my $retval = {};
1267              
1268             # Initialize the record
1269 6         15 $retval->{'category'} = 0; # Unfiled, by convention
1270 6         19 $retval->{'attributes'} = {
1271             # expunged => 0,
1272             dirty => 1, # Note: originally dirty
1273             'Dirty' => 1,
1274             # deleted => 0,
1275             # private => 0,
1276             # archive => 0,
1277             };
1278 6         14 $retval->{'id'} = 0; # Initially, no record ID
1279              
1280 6         10 return $retval;
1281             }
1282              
1283             =head2 append_Record
1284              
1285             $record = $pdb->append_Record;
1286             $record2 = $pdb->append_Record($record1);
1287              
1288             If called without any arguments, creates a new record with
1289             L, and appends it to $pdb.
1290              
1291             If given a reference to a record, appends that record to
1292             @{$pdb->{records}}.
1293              
1294             Returns a reference to the newly-appended record.
1295              
1296             This method updates $pdb's "last modification" time.
1297              
1298             =cut
1299             #'
1300              
1301             # append_Record
1302             # Append the given records to the database's list of records. If no
1303             # records are given, create one, append it, and return a reference to
1304             # it.
1305             sub append_Record
1306             {
1307 6     6 1 13 my $self = shift;
1308              
1309 6 50       19 if ($#_ < 0)
1310             {
1311             # No arguments given. Create a new record.
1312 6         36 my $record = $self->new_Record;
1313              
1314 6         12 push @{$self->{records}}, $record;
  6         15  
1315              
1316             # Update the "last modification time".
1317 6         10 $self->{mtime} = time;
1318              
1319 6         20 return $record;
1320             }
1321              
1322             # At least one argument was given. Append all of the arguments
1323             # to the list of records, and return the first one.
1324 0           push @{$self->{records}}, @_;
  0            
1325              
1326             # Update the "last modification time".
1327 0           $self->{mtime} = time;
1328              
1329 0           return $_[0];
1330             }
1331              
1332             =head2
1333              
1334             $resource = Palm::PDB->new_Resource();
1335             $resource = new_Resource Palm::PDB;
1336              
1337             Creates a new resource and initializes
1338              
1339             $resource->{type}
1340             $resource->{id}
1341              
1342             =cut
1343              
1344             # new_Resource
1345             # Create a new, initialized resource, and return a reference to it.
1346             sub new_Resource
1347             {
1348 0     0 0   my $classname = shift;
1349 0           my $retval = {};
1350              
1351             # Initialize the resource
1352 0           $retval->{type} = "\0\0\0\0";
1353 0           $retval->{id} = 0;
1354              
1355 0           return $retval;
1356             }
1357              
1358             =head2 append_Resource
1359              
1360             $resource = $pdb->append_Resource;
1361             $resource2 = $pdb->append_Resource($resource1);
1362              
1363             If called without any arguments, creates a new resource with
1364             L, and appends it to $pdb.
1365              
1366             If given a reference to a resource, appends that resource to
1367             @{$pdb->{resources}}.
1368              
1369             Returns a reference to the newly-appended resource.
1370              
1371             This method updates $pdb's "last modification" time.
1372              
1373             =cut
1374             #'
1375              
1376             # append_Resource
1377             # Append the given resources to the database's list of resources. If no
1378             # resources are given, create one, append it, and return a reference to
1379             # it.
1380             sub append_Resource
1381             {
1382 0     0 1   my $self = shift;
1383              
1384 0 0         if ($#_ < 0)
1385             {
1386             # No arguments given. Create a new resource
1387 0           my $resource = $self->new_Resource;
1388              
1389 0           push @{$self->{resources}}, $resource;
  0            
1390              
1391             # Update the "last modification time".
1392 0           $self->{mtime} = time;
1393              
1394 0           return $resource;
1395             }
1396              
1397             # At least one argument was given. Append all of the arguments
1398             # to the list of resources, and return the first one.
1399 0           push @{$self->{resources}}, @_;
  0            
1400              
1401             # Update the "last modification time".
1402 0           $self->{mtime} = time;
1403              
1404 0           return $_[0];
1405             }
1406              
1407             =head2 findRecordByID
1408              
1409             $record = $pdb->findRecordByID($id);
1410              
1411             Looks through the list of records in $pdb, and returns a reference to
1412             the record with ID $id, or the undefined value if no such record was
1413             found.
1414              
1415             =cut
1416              
1417             # findRecordByID
1418             # Returns a reference to the record with the given ID, or 'undef' if
1419             # it doesn't exist.
1420             sub findRecordByID
1421             {
1422 0     0 1   my $self = shift;
1423 0           my $id = shift;
1424              
1425 0 0         return undef if $id eq "";
1426              
1427 0           for (@{$self->{records}})
  0            
1428             {
1429 0 0         next unless $_->{id} == $id;
1430 0           return $_; # Found it
1431             }
1432              
1433 0           return undef; # Not found
1434             }
1435              
1436             =head2 delete_Record
1437              
1438             $pdb->delete_Record($record, $expunge);
1439              
1440             Marks $record for deletion, so that it will be deleted from the
1441             database at the next sync.
1442              
1443             If $expunge is false or omitted, the record will be marked
1444             for deletion with archival. If $expunge is true, the record will be
1445             marked for deletion without archival.
1446              
1447             This method updates $pdb's "last modification" time.
1448              
1449             =cut
1450             #'
1451              
1452             # delete_Record
1453             # $pdb->delete_Record($record ?, $expunge?)
1454             #
1455             # Mark the given record for deletion. If $expunge is true, mark the
1456             # record for deletion without an archive.
1457              
1458             sub delete_Record
1459             {
1460 0     0 1   my $self = shift;
1461 0           my $record = shift;
1462 0           my $expunge = shift;
1463              
1464 0           $record->{attributes}{deleted} = 1;
1465 0 0         if ($expunge)
1466             {
1467 0           $record->{attributes}{expunged} = 1;
1468 0           $record->{attributes}{archive} = 0;
1469             } else {
1470 0           $record->{attributes}{expunged} = 0;
1471 0           $record->{attributes}{archive} = 1;
1472             }
1473              
1474             # Update the "last modification time".
1475 0           $self->{mtime} = time;
1476             }
1477              
1478             1;
1479              
1480             __END__