File Coverage

blib/lib/XML/Handler/Pdb.pm
Criterion Covered Total %
statement 9 9 100.0
branch n/a
condition n/a
subroutine 3 3 100.0
pod n/a
total 12 12 100.0


line stmt bran cond sub pod time code
1             # $Id: Pdb.pm,v 1.4 2003/04/06 21:17:47 cvsjohan Exp $
2              
3             package XML::Handler::Pdb;
4 1     1   69787 use strict;
  1         2  
  1         41  
5 1     1   7 use warnings;
  1         2  
  1         48  
6              
7             our $VERSION = '0.2';
8              
9 1     1   7 use base 'XML::Handler::Subs';
  1         7  
  1         2091  
10              
11             use Carp;
12             use Palm::PDB;
13             use Palm::Raw;
14             use File::Temp 'tempfile';
15              
16             sub new {
17             my ($proto, %arg) = @_;
18              
19             my $self = $proto->SUPER::new(%arg);
20              
21             $self->{_verbose} = $arg{Verbose} || 0;
22              
23             print "Output to ", $self->{Output}, "\n" if $self->{_verbose};
24              
25             if (!defined($self->{Output})) {
26             ( $self->{_TempFH}, $self->{_Tempfile} ) = tempfile;
27             $self->{_Output} = $self->{_Tempfile};
28             } else {
29             $self->{_Output} = $self->{Output};
30             }
31             return $self;
32             }
33              
34             sub s_pdb {
35             my ($self, $el) = @_;
36              
37             print "start pdb\n" if $self->{_verbose};
38              
39             my $pdb = Palm::Raw->new;
40             $pdb->{"name"} = $el->{Attributes}{"{}name"}{Value};
41             $pdb->{"type"} = "DATA";
42             $pdb->{"creator"} = $el->{Attributes}{"{}creator"}{Value};
43             $self->{_pdb} = $pdb;
44             }
45              
46             sub e_pdb {
47             my ($self, $el) = @_;
48              
49             print "end pdb\n" if $self->{_verbose};
50              
51             $self->{_pdb}->Write($self->{_Output});
52             if (defined $self->{_TempFH}) {
53             my $fh = $self->{_TempFH};
54             my $buf;
55             while ($fh->read($buf, 2048)) { print $buf };
56             $fh->close;
57             }
58             $self->{_pdb} = undef;
59             }
60              
61             sub s_record {
62             my ($self, $el) = @_;
63              
64             print "start record\n" if $self->{_verbose};
65            
66             $self->{_actual_record} = $self->{_pdb}->new_Record;
67             $self->{_actual_record}->{"category"}
68             = $el->{Attributes}{"{}category"}{Value} || 0;
69             }
70              
71             sub e_record {
72             my ($self, $el) = @_;
73              
74             print "end record\n" if $self->{_verbose};
75              
76             $self->{_pdb}->append_Record($self->{_actual_record});
77             $self->{actual_record} = undef;
78             }
79              
80             sub s_field {
81             my ($self, $el) = @_;
82              
83             print "start field\n" if $self->{_verbose};
84              
85             my $type = $el->{Attributes}{"{}type"}{Value};
86             $self->{_field_type} = $type;
87              
88             if (exists($el->{Attributes}{"{}value"})) {
89             $self->{_field_value} = $el->{Attributes}{"{}value"}{Value};
90             }
91             }
92              
93             sub e_field {
94             my ($self, $element) = @_;
95              
96             my $data;
97             my $type = $self->{_field_type};
98              
99             print "type := $type\n" if $self->{_verbose};
100             if ($self->{_verbose} && defined $self->{_field_value}) {
101             print "value := ", $self->{_field_value}, "\n";
102             }
103             if ($self->{_verbose} && defined $self->{_chars}) {
104             print "value := ", $self->{_chars}, "\n";
105             }
106              
107             # For each type, transform the type to the NSBasic equivalent ...
108             #
109             if ($type eq 'text') {
110             # Text does not need processing
111             $data = $self->{_chars} . "\0";
112             } elsif ($type eq 'int') {
113             # Int is stored i/t attribute
114             $data = pack("N", $self->{_field_value});
115             } elsif ($type eq 'date') {
116             # Date
117             my $packed = pack("d",
118             $self->convert_date_to_nsbasic($self->{_field_value}));
119             $data = pack("C*", reverse unpack("C*", $packed));
120             } elsif ($type eq 'time') {
121             # Time
122             my $packed = pack("d",
123             $self->convert_time_to_nsbasic($self->{_field_value}));
124             $data = pack("C*", reverse unpack("C*", $packed));
125             } elsif ($type eq 'byte') {
126             # Byte
127             $data = pack("C", $self->{_field_value});
128             } elsif ($type eq 'float' || $type eq 'double') {
129             # Float and double
130             my $packed = pack("d", $self->{_field_value});
131             $data = pack("C*", reverse unpack("C*", $packed));
132             } elsif ($type eq 'short') {
133             # 16 bit signed int
134             $data = pack("n", $self->{_field_value});
135             }
136             $self->{_chars} = undef;
137             $self->{_field_type} = undef;
138             $self->{_field_value} = undef;
139             $self->{_actual_record}->{"data"} .= $data;
140              
141             print "end field\n" if $self->{_verbose};
142             }
143              
144             sub characters {
145             my ($self,$chars) = @_;
146              
147             print "characters ...\n" if $self->{_verbose};
148              
149             return unless $self->in_element('field');
150            
151             print "characters in field ...\n" if $self->{_verbose};
152              
153             $self->{_chars} .= $chars->{Data};
154             }
155              
156             sub convert_date_to_nsbasic {
157             my ($self, $rawdate) = @_;
158            
159             my ($year, $month, $day) = ( $rawdate =~ /(\d+)-(\d+)-(\d+)/ );
160             return ($year-1900)*10000+$month*100+$day;
161             }
162              
163             sub convert_time_to_nsbasic {
164             my ($self, $rawdate) = @_;
165              
166             my ($hour, $minute, $second) = ( $rawdate =~ /(\d+):(\d+):(\d+)/ );
167             return $hour*10000+$minute*100+$second;
168             }
169              
170             1;
171              
172             __END__