File Coverage

blib/lib/Palm/Datebook.pm
Criterion Covered Total %
statement 98 259 37.8
branch 27 100 27.0
condition 3 42 7.1
subroutine 7 11 63.6
pod 6 6 100.0
total 141 418 33.7


line stmt bran cond sub pod time code
1             package Palm::Datebook;
2             #
3             # ABSTRACT: Handler for Palm OS DateBook and Calendar databases
4             #
5             # Copyright (C) 1999-2001, Andrew Arensburger.
6             #
7             # This program is free software; you can redistribute it and/or modify
8             # it under the same terms as Perl itself.
9             #
10             # This program is distributed in the hope that it will be useful,
11             # but WITHOUT ANY WARRANTY; without even the implied warranty of
12             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either the
13             # GNU General Public License or the Artistic License for more details.
14              
15 2     2   6121 use strict;
  2         14  
  2         62  
16 2     2   477 use Palm::Raw();
  2         313  
  2         24  
17 2     2   348 use Palm::StdAppInfo();
  2         3  
  2         34  
18              
19 2     2   6 use vars qw( $VERSION @ISA );
  2         2  
  2         3629  
20              
21             # One liner, to allow MakeMaker to work.
22             $VERSION = '1.015';
23             # This file is part of Palm 1.015 (February 14, 2015)
24              
25             @ISA = qw( Palm::StdAppInfo Palm::Raw );
26              
27              
28             #'
29              
30             sub import
31             {
32 2     2   21 &Palm::PDB::RegisterPDBHandlers(__PACKAGE__,
33             [ "date", "DATA" ],
34             [ "PDat", "DATA" ],
35             );
36             }
37              
38             #'
39              
40             # new
41             # Create a new Palm::Datebook database, and return it
42             sub new
43             {
44 0     0 1 0 my $classname = shift;
45 0   0     0 my $params = $_[0] || {};
46 0         0 my $self = $classname->SUPER::new(@_);
47             # Create a generic PDB. No need to rebless it,
48             # though.
49              
50 0 0 0     0 if ($params->{app} eq 'Calendar' || $self->{creator} eq 'PDat') {
51 0   0     0 $self->{name} ||= "CalendarDB-PDat"; # Default
52 0 0       0 $self->{creator} = "PDat" if $self->{creator} eq "\0\0\0\0";
53             } else {
54 0   0     0 $self->{name} ||= "DatebookDB"; # Default
55 0 0       0 $self->{creator} = "date" if $self->{creator} eq "\0\0\0\0";
56             }
57 0 0       0 $self->{type} = "DATA" if $self->{type} eq "\0\0\0\0";
58 0         0 $self->{attributes}{resource} = 0;
59             # The PDB is not a resource database by
60             # default, but it's worth emphasizing,
61             # since DatebookDB is explicitly not a PRC.
62 0         0 $self->{appinfo} = {
63             start_of_week => 0, # XXX - This is bogus
64             };
65 0         0 &Palm::StdAppInfo::seed_StdAppInfo($self->{appinfo});
66              
67 0         0 $self->{sort} = undef; # Empty sort block
68              
69 0         0 $self->{records} = []; # Empty list of records
70              
71 0         0 return $self;
72             }
73              
74              
75             sub new_Record
76             {
77 0     0 1 0 my $classname = shift;
78 0         0 my $retval = $classname->SUPER::new_Record(@_);
79              
80             # By default, the new record is an untimed event that occurs
81             # today.
82 0         0 my @now = localtime(time);
83              
84 0         0 $retval->{day} = $now[3];
85 0         0 $retval->{month} = $now[4] + 1;
86 0         0 $retval->{year} = $now[5] + 1900;
87              
88 0         0 $retval->{start_hour} =
89             $retval->{start_minute} =
90             $retval->{end_hour} =
91             $retval->{end_minute} = 0xff;
92              
93             # Set the alarm. Defaults to 10 minutes before the event.
94 0         0 $retval->{alarm}{advance} = 10;
95 0         0 $retval->{alarm}{unit} = 0; # Minutes
96              
97 0         0 $retval->{repeat} = {}; # No repeat
98 0         0 $retval->{exceptions} = []; # No exceptions
99              
100 0         0 $retval->{description} = "";
101 0         0 $retval->{note} = undef;
102 0         0 $retval->{location} = undef;
103              
104 0         0 return $retval;
105             }
106              
107             # ParseAppInfoBlock
108             # Parse the AppInfo block for Datebook databases.
109             # There appears to be one byte of padding at the end.
110             sub ParseAppInfoBlock
111             {
112 1     1 1 487 my $self = shift;
113 1         2 my $data = shift;
114 1         3 my $startOfWeek;
115             my $i;
116 1         3 my $appinfo = {};
117 1         2 my $std_len;
118              
119             # Get the standard parts of the AppInfo block
120 1         5 $std_len = &Palm::StdAppInfo::parse_StdAppInfo($appinfo, $data);
121              
122 1         2 $data = $appinfo->{other}; # Look at non-category part
123              
124             # Get the rest of the AppInfo block
125 1         1 my $unpackstr = # Argument to unpack(), since it's hairy
126             "x2" . # Padding
127             "C"; # Start of week
128              
129             # XXX - This is actually "sortOrder". Dunno what that is,
130             # though.
131 1         2 ($startOfWeek) = unpack $unpackstr, $data;
132              
133 1         2 $appinfo->{start_of_week} = $startOfWeek;
134              
135 1         3 return $appinfo;
136             }
137              
138             sub PackAppInfoBlock
139             {
140 0     0 1 0 my $self = shift;
141 0         0 my $retval;
142              
143             # Pack the non-category part of the AppInfo block
144 0         0 $self->{appinfo}{other} =
145             pack("x2 C x", $self->{appinfo}{start_of_week});
146              
147             # Pack the standard part of the AppInfo block
148 0         0 $retval = &Palm::StdAppInfo::pack_StdAppInfo($self->{appinfo});
149              
150 0         0 return $retval;
151             }
152              
153             sub ParseRecord
154             {
155 7     7 1 114 my $self = shift;
156 7         15 my %record = @_;
157 7         7 my $data;
158 7         8 my $iscal = ($self->{creator} eq 'PDat');
159              
160 7         8 delete $record{offset}; # This is useless
161              
162             # Untimed events have 0xff for $startHour, $startMinute,
163             # $endHour and $endMinute.
164 7         8 my $startHour; # In 24-hour format
165             my $startMinute;
166 0         0 my $endHour; # In 24-hour format
167 0         0 my $endMinute;
168 0         0 my $rawDate;
169 0         0 my $flags;
170 7         8 my $unpackstr = # Argument to unpack().
171             "C C" . # Start hour, minute
172             "C C" . # End hour, minute
173             "n" . # Raw date
174             "n"; # Flags
175              
176 7         8 $data = $record{data};
177 7         12 ($startHour, $startMinute, $endHour, $endMinute, $rawDate,
178             $flags) =
179             unpack $unpackstr, $data;
180 7         10 $data = substr $data, 8; # Chop off the part we've just parsed
181              
182 7         3 my $year;
183             my $month;
184 0         0 my $day;
185              
186 7         8 $day = $rawDate & 0x001f; # 5 bits
187 7         8 $month = ($rawDate >> 5) & 0x000f; # 4 bits
188 7         7 $year = ($rawDate >> 9) & 0x007f; # 7 bits (years since 1904)
189 7         4 $year += 1904;
190              
191 7         9 $record{start_hour} = $startHour;
192 7         8 $record{start_minute} = $startMinute;
193 7         5 $record{end_hour} = $endHour;
194 7         10 $record{end_minute} = $endMinute;
195 7         6 $record{day} = $day;
196 7         5 $record{month} = $month;
197 7         6 $record{year} = $year;
198              
199             # Flags
200 7 50       11 my $when_changed = ($flags & 0x8000 ? 1 : 0);
201 7 100       12 my $have_alarm = ($flags & 0x4000 ? 1 : 0);
202 7 100       9 my $have_repeat = ($flags & 0x2000 ? 1 : 0);
203 7 50       9 my $have_note = ($flags & 0x1000 ? 1 : 0);
204 7 50       8 my $have_exceptions = ($flags & 0x0800 ? 1 : 0);
205 7 50       8 my $have_description = ($flags & 0x0400 ? 1 : 0);
206 7 50 33     16 my $have_location = (($iscal && ($flags & 0x0200)) ? 1 : 0);
207              
208 7 50       11 $record{other_flags} = $flags & ($iscal ? 0x01ff : 0x03ff);
209              
210 7 50       472 if ($when_changed)
211             {
212 0         0 $record{when_changed} = 1;
213             }
214              
215 7 100       11 if ($have_alarm)
216             {
217 2         2 my $advance;
218             my $adv_unit;
219              
220 2         3 ($advance, $adv_unit) = unpack "cC", $data;
221 2         2 $data = substr $data, 2; # Chop off alarm data
222              
223 2         3 $record{alarm}{advance} = $advance;
224 2         3 $record{alarm}{unit} = $adv_unit;
225             }
226              
227 7 100       10 if ($have_repeat)
228             {
229 3         2 my $type;
230             my $endDate;
231 0         0 my $frequency;
232 0         0 my $repeatOn;
233 0         0 my $repeatStartOfWeek;
234 0         0 my $unknown;
235              
236 3         7 ($type, $endDate, $frequency, $repeatOn, $repeatStartOfWeek,
237             $unknown) =
238             unpack "Cx n C C C C", $data;
239 3         6 $data = substr $data, 8; # Chop off repeat part
240              
241 3         5 $record{repeat}{type} = $type;
242 3         4 $record{repeat}{unknown} = $unknown;
243              
244 3 100       5 if ($endDate != 0xffff)
245             {
246 1         1 my $endYear;
247             my $endMonth;
248 0         0 my $endDay;
249              
250 1         2 $endDay = $endDate & 0x001f; # 5 bits
251 1         1 $endMonth = ($endDate >> 5) & 0x000f; # 4 bits
252 1         1 $endYear = ($endDate >> 9) & 0x007f; # 7 bits (years
253 1         1 $endYear += 1904; # since 1904)
254              
255 1         1 $record{repeat}{end_day} = $endDay;
256 1         2 $record{repeat}{end_month} = $endMonth;
257 1         1 $record{repeat}{end_year} = $endYear;
258             }
259              
260 3         4 $record{repeat}{frequency} = $frequency;
261 3 100       7 if ($type == 2)
    50          
262             {
263             # "Weekly" repeat
264 1         1 my $i;
265             my @days;
266              
267             # Build an array of 7 elements (one for each
268             # day of the week). Each element is set iff
269             # the appointment repeats on that day.
270 1         3 for ($i = 0; $i < 7; $i++)
271             {
272 7 100       9 if ($repeatOn & (1 << $i))
273             {
274 1         2 $days[$i] = 1;
275             } else {
276 6         10 $days[$i] = 0;
277             }
278             }
279              
280 1         3 $record{repeat}{repeat_days} = [ @days ];
281 1         3 $record{repeat}{start_of_week} =
282             $repeatStartOfWeek;
283             # I don't know what this is,
284             # but the Datebook app appears
285             # to perform some hairy
286             # calculations involving this.
287             } elsif ($type == 3) {
288             # "Monthly by day" repeat
289             # If "weeknum" is 5, it means the last week of
290             # the month
291 0         0 $record{repeat}{weeknum} = int($repeatOn / 7);
292 0         0 $record{repeat}{daynum} = $repeatOn % 7;
293             }
294             }
295              
296 7 50       9 if ($have_exceptions)
297             {
298 0         0 my $numExceptions;
299             my @exceptions;
300              
301 0         0 $numExceptions = unpack "n", $data;
302 0         0 $data = substr $data, 2;
303 0         0 @exceptions = unpack "n" x $numExceptions, $data;
304 0         0 $data = substr $data, 2 * $numExceptions;
305              
306 0         0 my $exception;
307 0         0 foreach $exception (@exceptions)
308             {
309 0         0 my $year;
310             my $month;
311 0         0 my $day;
312              
313 0         0 $day = $exception & 0x001f;
314 0         0 $month = ($exception >> 5) & 0x000f;
315 0         0 $year = ($exception >> 9) & 0x007f;
316 0         0 $year += 1904;
317              
318 0         0 push @{$record{exceptions}},
  0         0  
319             [ $day, $month, $year ];
320             }
321             }
322              
323 7         16 my @fields = split /\0/, $data, -1;
324              
325 7 50       11 if ($have_description)
326             {
327 7         5 my $description;
328              
329 7         7 $description = shift @fields;
330 7         8 $record{description} = $description;
331             }
332              
333 7 50       9 if ($have_note)
334             {
335 0         0 my $note;
336              
337 0         0 $note = shift @fields;
338 0         0 $record{note} = $note;
339             }
340              
341 7 50       9 if ($have_location)
342             {
343 0         0 my $location;
344              
345 0         0 $location = shift @fields;
346 0         0 $record{location} = $location;
347             }
348              
349 7         9 my $other_data= join ("\0", @fields);
350              
351 7 0 33     11 if ($iscal && length ($other_data) >= 21 && substr ($other_data, 0, 4) eq 'Bd00') {
      33        
352 0         0 my $len= unpack ('n', substr ($other_data, 4, 2));
353 0 0       0 if ($len+6 <= length ($other_data)) {
354 0         0 my $tzdata= substr ($other_data, 6, $len);
355 0         0 $other_data= substr ($other_data, $len+6);
356 0         0 @{$record{timezone}}{qw(offset start_hour start_daynum start_weeknum start_month
  0         0  
357             end_hour end_daynum end_weeknum end_month
358             dst_adjustment country flags name)}= unpack ('n C8 n C2 a*', $tzdata);
359 0         0 $record{timezone}{name} =~ s/\0$//;
360 0 0       0 $record{timezone}{offset}= $record{timezone}{offset} -65536
361             if $record{timezone}{offset} > 32767; # signed short
362 0 0       0 $record{timezone}{dst_adjustment}= $record{timezone}{dst_adjustment}-65536
363             if $record{timezone}{dst_adjustment} > 32767; # signed short
364 0 0       0 $record{timezone}{custom}= ($record{timezone}{flags} & 0x80) ? 1 : 0;
365 0         0 $record{timezone}{flags} &= 0x7f;
366 0         0 $record{timezone}{data}= $tzdata;
367             }
368             }
369              
370 7 50       12 $record{other_data}= $other_data if $other_data ne '';
371              
372 7         7 delete $record{data};
373              
374 7         17 return \%record;
375             }
376              
377             sub PackRecord
378             {
379 0     0 1   my $self = shift;
380 0           my $record = shift;
381 0           my $retval;
382              
383             my $rawDate;
384 0           my $flags;
385 0           my $iscal = ($self->{creator} eq 'PDat');
386              
387 0           $rawDate = ($record->{day} & 0x001f) |
388             (($record->{month} & 0x000f) << 5) |
389             ((($record->{year} - 1904) & 0x007f) << 9);
390              
391             # XXX - Better to collect data first, then build flags.
392 0           $flags = $record->{other_flags};
393             # $flags |= 0x8000 if $record->{when_changed};
394             # $flags |= 0x4000 if keys %{$record->{alarm} } ne ();
395             # $flags |= 0x2000 if keys %{$record->{repeat} } ne ();
396             # $flags |= 0x1000 if $record->{note} ne "";
397             # $flags |= 0x0800 if $#{$record->{exceptions} } >= 0;
398             # $flags |= 0x0400 if $record->{description} ne "";
399             # $flags |= 0x0200 if $iscal && $record->{location} ne "";
400              
401             # $retval = pack "C C C C n n",
402             # $record->{start_hour},
403             # $record->{start_minute},
404             # $record->{end_hour},
405             # $record->{end_minute},
406             # $rawDate,
407             # $flags;
408              
409 0 0         if ($record->{when_changed})
410             {
411 0           $flags |= 0x8000;
412             }
413              
414 0           my $alarm = undef;
415              
416 0 0 0       if (defined($record->{alarm}) && %{$record->{alarm}})
  0            
417             {
418 0           $flags |= 0x4000;
419 0           $alarm = pack "c C",
420             $record->{alarm}{advance},
421             $record->{alarm}{unit};
422             }
423              
424 0           my $repeat = undef;
425              
426 0 0 0       if (defined($record->{repeat}) && %{$record->{repeat}})
  0            
427             {
428 0           my $type; # Repeat type
429 0           my $endDate = 0xffff; # No end date defined by default
430 0           my $repeatOn = 0;
431 0           my $repeatStartOfWeek = 0;
432              
433 0           $flags |= 0x2000;
434              
435 0 0         if (defined($record->{repeat}{end_day}))
436             {
437             # End date defined
438 0           $endDate =
439             ($record->{repeat}{end_day} & 0x001f) |
440             (($record->{repeat}{end_month}
441             & 0x000f) << 5) |
442             ((($record->{repeat}{end_year} - 1904)
443             & 0x007f) << 9);
444             }
445              
446 0 0         if ($record->{repeat}{type} == 2)
    0          
447             {
448             # Weekly repeat
449 0           my $i;
450              
451 0           $repeatOn = 0;
452 0           for ($i = 0; $i < 7; $i++)
453             {
454 0 0         if ($record->{repeat}{repeat_days}[$i])
455             {
456 0           $repeatOn |= (1 << $i);
457             }
458             }
459 0           $repeatStartOfWeek = $record->{repeat}{start_of_week};
460             } elsif ($record->{repeat}{type} == 3)
461             {
462             # "Monthly by day" repeat
463 0           my $weeknum = $record->{repeat}{weeknum};
464              
465 0 0         if ($weeknum > 5)
466             {
467 0           $weeknum = 5;
468             }
469 0           $repeatOn = ($record->{repeat}{weeknum} * 7) +
470             ($record->{repeat}{daynum} % 7);
471             }
472              
473 0           $repeat = pack "Cx n C C C C",
474             $record->{repeat}{type},
475             $endDate,
476             $record->{repeat}{frequency},
477             $repeatOn,
478             $repeatStartOfWeek,
479             $record->{repeat}{unknown};
480             }
481              
482 0           my $exceptions = undef;
483              
484 0 0 0       if (defined($record->{exceptions}) && @{$record->{exceptions}})
  0            
485             {
486 0           my $numExceptions = $#{$record->{exceptions}} + 1;
  0            
487 0           my $exception;
488              
489 0           $flags |= 0x0800;
490              
491 0           $exceptions = pack("n", $numExceptions);
492              
493 0           foreach $exception (@{$record->{exceptions}})
  0            
494             {
495 0           my $day = $exception->[0];
496 0           my $month = $exception->[1];
497 0           my $year = $exception->[2];
498              
499 0           $exceptions .= pack("n",
500             ($day & 0x001f) |
501             (($month & 0x000f) << 5) |
502             ((($year - 1904) & 0x007f) << 9));
503             }
504             }
505              
506 0           my $description = undef;
507              
508 0 0 0       if (defined($record->{description}) && ($record->{description} ne ""))
509             {
510 0           $flags |= 0x0400;
511 0           $description = $record->{description} . "\0";
512             }
513              
514 0           my $note = undef;
515              
516 0 0 0       if (defined($record->{note}) && ($record->{note} ne ""))
517             {
518 0           $flags |= 0x1000;
519 0           $note = $record->{note} . "\0";
520             }
521              
522 0           my $location = undef;
523              
524 0 0 0       if ($iscal && defined($record->{location}) && ($record->{location} ne ""))
      0        
525             {
526 0           $flags |= 0x0200;
527 0           $location = $record->{location} . "\0";
528             }
529              
530 0           $retval = pack "C C C C n n",
531             $record->{start_hour},
532             $record->{start_minute},
533             $record->{end_hour},
534             $record->{end_minute},
535             $rawDate,
536             $flags;
537              
538 0 0         $retval .= $alarm if defined($alarm);
539 0 0         $retval .= $repeat if defined($repeat);
540 0 0         $retval .= $exceptions if defined($exceptions);
541 0 0         $retval .= $description if defined($description);
542 0 0         $retval .= $note if defined($note);
543 0 0         $retval .= $location if defined($location);
544              
545 0 0 0       if ($iscal && $record->{timezone}) {
546 0           my $tzflags= $record->{timezone}{flags};
547 0 0         $tzflags |= 0x80 if $record->{timezone}{custom};
548 0           my $tzdata = pack ('n C8 n C2',
549 0           @{$record->{timezone}}{qw(offset start_hour start_daynum start_weeknum start_month
550             end_hour end_daynum end_weeknum end_month
551             dst_adjustment country)}, $tzflags);
552 0           $tzdata .= "$record->{timezone}{name}\0";
553 0           $retval .= 'Bd00';
554 0           $retval .= pack ('n', length ($tzdata));
555 0           $retval .= $tzdata;
556             }
557              
558 0 0         $retval .= $record->{other_data} if exists $record->{other_data};
559              
560 0           return $retval;
561             }
562              
563             1;
564              
565             __END__