File Coverage

File:blib/lib/DBD/XMLSimple.pm
Coverage:90.5%

linestmtbrancondsubtimecode
1package DBD::XMLSimple;
2
3
5
5
5
5
547928
4
113
use warnings;
4
5
5
5
5
9
3
71
use strict;
5
6 - 14
=head1 NAME

DBD::XMLSimple - Access XML data via the DBI interface

=head1 VERSION

Version 0.08

=cut
15
16 - 68
=head1 SYNOPSIS

Reads XML and makes it available via DBI.

Sadly, DBD::AnyData doesn't work with the latest DBI,
and DBD::AnyData2 isn't out yet, so I am writing this pending the publication of DBD::AnyData2.

DBD-XMLSimple doesn't yet expect to support complex XML data, so that's why
it's not called DBD-XML.

The XML file needs to have a <table> containing the entry/entries.

    use FindBin qw($Bin);
    use DBI;

    my $dbh = DBI->connect('dbi:XMLSimple(RaiseError => 1):');

    $dbh->func('person', 'XML', "$Bin/../data/person.xml", 'xmlsimple_import');

    my $sth = $dbh->prepare('SELECT * FROM person');

Input data will be something like this:

    <?xml version="1.0" encoding="US-ASCII"?>
    <table>
        <row id="1">
            <name>Nigel Horne</name>
            <email>njh@nigelhorne.com</email>
        </row>
        <row id="2">
            <name>A N Other</name>
            <email>nobody@example.com</email>
        </row>
    </table>

If a leaf appears twice,
it will be concatenated.

    <?xml version="1.0" encoding="US-ASCII"?>
    <table>
        <row id="1">
            <name>Nigel Horne</name>
            <email>njh@nigelhorne.com</email>
            <email>nhorne@pause.org</email>
        </row>
    </table>

    $sth = $dbh->prepare('Select email FROM person');
    $sth->execute();
    $sth->dump_results();

    Gives the output "njh@nigelhorne.com,nhorne@pause.org"
=cut
69
70 - 76
=head1 SUBROUTINES/METHODS

=head2 driver

No routines in this module should be called directly by the application.

=cut
77
78
5
5
5
5
13
3
1566
use base qw(DBI::DBD::SqlEngine);
79
80
5
5
5
5
252126
5
420
use vars qw($VERSION $drh $methods_already_installed);
81
82our $VERSION = '0.08';
83our $drh = undef;
84our $methods_already_installed = 0;
85
86sub driver
87{
88
4
50
4
1316
        return $drh if $drh;
89
90        # my($class, $attr) = @_;
91
4
22
        my $class = $_[0];
92
93        # $class .= '::dr';
94        # $drh = DBI::_new_drh($class, {
95        # $drh = DBI::_new_drh("$class::dr", {
96
4
29
        $drh = $class->SUPER::driver({
97                'Name' => 'XMLSimple',
98                'Version' => $VERSION,
99                'Attribution' => 'DBD::XMLSimple by Nigel Horne',
100        });
101
102
4
50
1327
        if($drh) {
103
4
6
                $class .= '::db';
104                # DBI->setup_driver($class);
105
4
50
43
                $class->install_method('xmlsimple_import') unless $drh->{methods_installed}++;
106        }
107
108
4
72
        return $drh;
109}
110
111sub CLONE
112{
113
0
0
0
        undef $drh;
114}
115
116package DBD::XMLSimple::dr;
117
118
5
5
5
5
11
5
221
use vars qw($imp_data_size);
119
120$imp_data_size = 0;
121
122sub disconnect_all
123{
124
4
4
2315
        shift->{tables} = {};
125}
126
127sub DESTROY
128{
129
0
0
0
        shift->{tables} = {};
130}
131
132# Database handle
133package DBD::XMLSimple::db;
134
135
5
5
5
5
10
5
717
use base qw(DBI::DBD::SqlEngine::db);
136
5
5
5
5
15
5
122
use Carp;
137
138
5
5
5
5
15
4
269
use vars qw($imp_data_size);
139
140$DBD::XMLSimple::db::imp_data_size = 0;
141
142sub xmlsimple_import
143{
144        # my($dbh, $table_name, $format, $filename, $flags) = @_;
145
7
7
1752
        my($dbh, $table_name, $format, $filename) = @_;
146
147
7
50
10
        croak("Format must be 'XML'") unless $format eq 'XML';
148
149        # $dbh->{tables} ||= {};
150
7
49
        $dbh->{tables}{$table_name} = { filename => $filename, rows => [], col_names => [] };
151}
152
153package DBD::XMLSimple::st;
154
155
5
5
5
5
11
15
45
use strict;
156
5
5
5
5
6
4
90
use warnings;
157
158
5
5
5
5
8
5
642
use base qw(DBI::DBD::SqlEngine::st);
159
160
5
5
5
5
11
3
114
use vars qw($imp_data_size);
161
162$DBD::XMLSimple::st::imp_data_size = 0;
163
164# Statement handle
165package DBD::XMLSimple::Statement;
166
5
5
5
5
8
3
569
use base qw(DBI::DBD::SqlEngine::Statement);
167
168
5
5
5
5
9
5
56
use strict;
169
5
5
5
5
9
7
98
use warnings;
170
171
5
5
5
5
1088
7073
110
use Data::Reuse;
172
5
5
5
5
11
4
103
use Carp;
173
5
5
5
5
5159
194199
1183
use XML::Twig;
174
175sub open_table($$$$$)
176{
177
14
14
21038
        my ($self, $data, $tname) = @_;
178
14
12
        my $dbh = $data->{Database};
179
180        # Determine the table name
181
14
0
33
18
0
        $tname ||= (keys %{$dbh->{tables}})[0];      # fallback to first registered table
182
14
50
23
        my $table_info = $dbh->{tables}{$tname}
183                or croak "No XML file registered for table '$tname'";
184
185
14
9
        my $source = $table_info->{filename};
186
187
14
30
        my $twig = XML::Twig->new();
188
189
14
100
13418
        if(ref($source) eq 'ARRAY') {
190
7
7
13
18
                $twig->parse(join('', @{$source}));
191        } else {
192
7
50
13
                $twig->parsefile($source) or croak("Cannot parse XML file '$source': $!");
193        }
194
195
14
24305
        my $root = $twig->root;
196
14
36
        my @records = $root->children();
197
198
14
100
188
        carp 'No rows found under <table>' if !@records;
199
200
14
225
        my @rows;
201        my %colnames_seen;
202
203        # First pass — discover columns across all rows
204
14
14
        for my $record (@records) {
205
30
29
                for my $leaf ($record->children) {
206
58
353
                        $colnames_seen{$leaf->name()}++;
207                }
208                # Also include 'id'
209
30
50
63
                if (defined(my $id = $record->att('id'))) {
210
30
69
                        $colnames_seen{id}++;
211                }
212        }
213
214
14
38
        my @col_names = sort keys %colnames_seen;
215
14
100
17
        if (!@col_names) {
216
1
4
                carp "Empty table, creating dummy column '_dummy'";
217
1
163
                @col_names = ('_dummy');
218        }
219
14
40
16
48
        my %col_nums = map { $col_names[$_] => $_ } 0..$#col_names;
220
221        # Second pass — save row values
222
14
17
        for my $record (@records) {
223
30
15
                my %row;
224
225                # Include id if present
226
30
50
27
                if (defined(my $id = $record->att('id'))) {
227
30
57
                        $row{id} = $id;
228                }
229
230
30
24
                for my $leaf ($record->children) {
231
58
483
                        my $key = $leaf->name;
232
58
100
94
                        if (defined $row{$key}) {
233
3
4
                                $row{$key} .= ',' . $leaf->field();
234                        } else {
235
55
44
                                $row{$key} = $leaf->field();
236                        }
237                }
238
239                # Now produce array in canonical column order
240
30
90
222
100
                push @rows, [ map { $row{$_} } @col_names ];
241        }
242
243        # $data->{rows} = \@rows;
244
14
22
        $data->{rows} = Data::Reuse::reuse(\@rows);
245
246        # Store table metadata
247
14
1098
        $data->{col_names} = \@col_names;
248
14
16
        $data->{col_nums}  = \%col_nums;
249
14
11
        $data->{row_count} = scalar @rows;
250
251
14
30
        return DBD::XMLSimple::Table->new($data, $data);
252}
253
254# Table handle
255package DBD::XMLSimple::Table;
256
5
5
5
5
22
5
759
use base qw(DBI::DBD::SqlEngine::Table);
257
258
5
5
5
5
14
5
50
use strict;
259
5
5
5
5
8
4
858
use warnings;
260
261sub new
262{
263
14
14
16
        my($class, $data, $attr, $flags) = @_;
264
265
14
11
        $attr->{table} = $data;
266
14
8
        $attr->{readonly} = 1;
267
14
14
        $attr->{cursor} = 0;
268
269
14
10
        $attr->{rows} = $data->{rows};
270
14
7
        $attr->{col_nums} = $data->{col_nums};
271
272
14
36
        my $rc = $class->SUPER::new($data, $attr, $flags);
273
274
14
356
        $rc->{col_names} = $attr->{col_names};
275
276
14
43
        return $rc;
277}
278
279sub fetch_row($$)
280{
281
44
44
5292
        my($self, $data) = @_;
282
283
44
100
46
        if($self->{'cursor'} >= $data->{'row_count'}) {
284
14
17
                return undef;
285        }
286
287
30
27
        $self->{row} = $self->{rows}[ $self->{cursor}++ ];
288
30
26
        return $self->{row};
289}
290
291sub seek($$$$)
292{
293
0
0
0
        my($self, $data, $pos, $whence) = @_;
294
295
0
0
        print "seek $pos $whence, not yet implemented\n";
296}
297
298sub complete_table_name($$$$)
299{
300
14
14
40
        my($self, $meta, $file, $respect_case, $file_is_table) = @_;
301}
302
303sub open_data
304
14
{
305        # my($className, $meta, $attrs, $flags) = @_;
306}
307
308sub bootstrap_table_meta
309{
310
14
14
165
        my($class, $dbh, $meta, $table, @other) = @_;
311
312
14
25
        $class->SUPER::bootstrap_table_meta($dbh, $meta, $table, @other);
313
314
14
81
        $meta->{table} = $table;
315
316
14
50
36
        $meta->{sql_data_source} ||= __PACKAGE__;
317}
318
319sub get_table_meta($$$$;$)
320{
321
14
14
61
        my($class, $dbh, $table, $file_is_table, $respect_case) = @_;
322
323
14
24
        my $meta = $class->SUPER::get_table_meta($dbh, $table, $respect_case, $file_is_table);
324
325
14
146
        $table = $meta->{table};
326
327
14
50
13
        return unless $table;
328
329
14
17
        return($table, $meta);
330}
331
332 - 384
=head1 AUTHOR

Nigel Horne, C<< <njh at nigelhorne.com> >>

=head1 BUGS

=head1 SEE ALSO

=over 4

=item * Test coverage report: L<https://nigelhorne.github.io/DBD-XMLSimple/coverage/>

=item * L<DBD::AnyData>, which was also used as a template for this module.

=back

=head1 REPOSITORY

L<https://github.com/nigelhorne/DBD-XMLSimple>

=head1 SUPPORT

This module is provided as-is without any warranty.

You can find documentation for this module with the perldoc command.

    perldoc DBD::XMLSimple

You can also look for information at:

=over 4

=item * RT: CPAN's request tracker

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=DBD-XMLSimple>

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/DBD-XMLSimple>

=item * Search CPAN

L<http://search.cpan.org/dist/DBD-XMLSimple/>

=back

=head1 LICENCE AND COPYRIGHT

Copyright 2016-2025 Nigel Horne.

This program is released under the following licence: GPL

=cut
385
3861; # End of DBD::XMLSimple