File Coverage

blib/lib/DBD/CSV.pm
Criterion Covered Total %
statement 207 218 94.9
branch 78 110 70.9
condition 23 41 56.1
subroutine 31 32 96.8
pod n/a
total 339 401 84.5


line stmt bran cond sub pod time code
1             #!/usr/bin/perl
2             #
3             # DBD::CSV - A DBI driver for CSV and similar structured files
4             #
5             # This module is currently maintained by
6             #
7             # H.Merijn Brand
8             #
9             # See for full acknowledgements the last two pod sections in this file
10              
11 23     23   3696807 use strict;
  23         61  
  23         796  
12 23     23   132 use warnings;
  23         62  
  23         2399  
13              
14             require DynaLoader;
15             require DBD::File;
16             require IO::File;
17              
18             our @f_SHORT = qw( file dir dir_search ext lock lockfile schema encoding );
19             our @c_SHORT = qw( class eof
20             eol sep_char quote_char escape_char binary decode_utf8 auto_diag
21             diag_verbose blank_is_undef empty_is_undef allow_whitespace
22             allow_loose_quotes allow_loose_escapes allow_unquoted_escape
23             always_quote quote_empty quote_space escape_null quote_binary
24             keep_meta_info callbacks );
25              
26             package DBD::CSV;
27              
28 23     23   144 use strict;
  23         50  
  23         605  
29              
30 23     23   116 use vars qw( @ISA $VERSION $ATTRIBUTION $drh $err $errstr $sqlstate );
  23         45  
  23         3894  
31              
32             @ISA = qw( DBD::File );
33              
34             $VERSION = "0.57";
35             $ATTRIBUTION = "DBD::CSV $DBD::CSV::VERSION by H.Merijn Brand";
36              
37             $err = 0; # holds error code for DBI::err
38             $errstr = ""; # holds error string for DBI::errstr
39             $sqlstate = ""; # holds error state for DBI::state
40             $drh = undef; # holds driver handle once initialized
41              
42       0     sub CLONE { # empty method: prevent warnings when threads are cloned
43             } # CLONE
44              
45             # --- DRIVER -------------------------------------------------------------------
46              
47             package DBD::CSV::dr;
48              
49 23     23   230 use strict;
  23         68  
  23         657  
50              
51 23     23   173 use Text::CSV_XS ();
  23         58  
  23         672  
52 23     23   156 use vars qw( @ISA @CSV_TYPES );
  23         46  
  23         8241  
53              
54             @CSV_TYPES = (
55             Text::CSV_XS::IV (), # SQL_TINYINT
56             Text::CSV_XS::IV (), # SQL_BIGINT
57             Text::CSV_XS::PV (), # SQL_LONGVARBINARY
58             Text::CSV_XS::PV (), # SQL_VARBINARY
59             Text::CSV_XS::PV (), # SQL_BINARY
60             Text::CSV_XS::PV (), # SQL_LONGVARCHAR
61             Text::CSV_XS::PV (), # SQL_ALL_TYPES
62             Text::CSV_XS::PV (), # SQL_CHAR
63             Text::CSV_XS::NV (), # SQL_NUMERIC
64             Text::CSV_XS::NV (), # SQL_DECIMAL
65             Text::CSV_XS::IV (), # SQL_INTEGER
66             Text::CSV_XS::IV (), # SQL_SMALLINT
67             Text::CSV_XS::NV (), # SQL_FLOAT
68             Text::CSV_XS::NV (), # SQL_REAL
69             Text::CSV_XS::NV (), # SQL_DOUBLE
70             );
71              
72             our @ISA = qw( DBD::File::dr );
73              
74             our $imp_data_size = 0;
75             our $data_sources_attr = undef;
76              
77             sub connect {
78 255     255   628869 my ($drh, $dbname, $user, $auth, $attr) = @_;
79 255 50 33     1816 if ($attr && ref $attr eq "HASH") {
80             # Top-level aliasses
81 255         898 foreach my $key (grep { exists $attr->{$_} } @f_SHORT) {
  2040         4373  
82 3         7 my $f_key = "f_$key";
83 3 50       6 exists $attr->{$f_key} and next;
84 3         7 $attr->{$f_key} = delete $attr->{$key};
85             }
86 255         859 foreach my $key (grep { exists $attr->{$_} } @c_SHORT) {
  5865         9997  
87 3         4 my $c_key = "csv_$key";
88 3 50       5 exists $attr->{$c_key} and next;
89 3         7 $attr->{$c_key} = delete $attr->{$key};
90             }
91             }
92              
93 255         1931 my $dbh = $drh->DBD::File::dr::connect ($dbname, $user, $auth, $attr);
94 255 50       260181 $dbh and $dbh->{Active} = 1;
95 255         3104 $dbh;
96             } # connect
97              
98             # --- DATABASE -----------------------------------------------------------------
99              
100             package DBD::CSV::db;
101              
102 23     23   208 use strict;
  23         63  
  23         15172  
103              
104             our $imp_data_size = 0;
105             our @ISA = qw( DBD::File::db );
106              
107             sub set_versions {
108 255     255   11421 my $this = shift;
109 255         701 $this->{csv_version} = $DBD::CSV::VERSION;
110 255         893 return $this->SUPER::set_versions ();
111             } # set_versions
112              
113             my %csv_xs_attr;
114              
115             sub init_valid_attributes {
116 255     255   29507 my $dbh = shift;
117              
118             # Straight from Text::CSV_XS.pm
119 255         1553 my @xs_attr = @c_SHORT;
120 255         2207 @csv_xs_attr{@xs_attr} = ();
121             # Dynamically add "new" attributes - available in Text::CSV_XS-1.20
122 255 50       611 if (my @ka = eval { Text::CSV_XS->known_attributes }) {
  255         1763  
123 255 100       9882 for (grep { m/^[a-su-z]/ && !exists $csv_xs_attr{$_} } @ka) {
  7395         22612  
124 138         230 push @xs_attr => $_;
125 138         269 $csv_xs_attr{$_} = undef;
126             }
127             };
128              
129 255         1554 $dbh->{csv_xs_valid_attrs} = [ @xs_attr ];
130              
131 255         938 $dbh->{csv_valid_attrs} = { map {("csv_$_" => 1 )} @xs_attr, qw(
  9063         18440  
132              
133             class tables in csv_in out csv_out skip_first_row
134              
135             null sep quote escape bom
136             )};
137              
138 255         1418 $dbh->{csv_readonly_attrs} = { };
139              
140 255         630 $dbh->{csv_meta} = "csv_tables";
141              
142 255         1303 return $dbh->SUPER::init_valid_attributes ();
143             } # init_valid_attributes
144              
145             sub get_csv_versions {
146 1     1   358 my ($dbh, $table) = @_;
147 1   50     8 $table ||= "";
148 1         2 my $class = $dbh->{ImplementorClass};
149 1         5 $class =~ s/::db$/::Table/;
150 1         2 my $meta;
151 1 50       5 $table and (undef, $meta) = $class->get_table_meta ($dbh, $table, 1);
152 1 50       6 unless ($meta) {
153 1         2 $meta = {};
154 1         9 $class->bootstrap_table_meta ($dbh, $meta, $table);
155             }
156 1         103 my $dvsn = eval { $meta->{csv_class}->VERSION (); };
  1         17  
157 1         3 my $dtype = $meta->{csv_class};
158 1 50       16 $dvsn and $dtype .= " ($dvsn)";
159 1         11 return sprintf "%s using %s", $dbh->{csv_version}, $dtype;
160             } # get_csv_versions
161              
162             sub get_info {
163 209     209   314335 my ($dbh, $info_type) = @_;
164 209         4069 require DBD::CSV::GetInfo;
165 209         869 my $v = $DBD::CSV::GetInfo::info{int ($info_type)};
166 209 50       746 ref $v eq "CODE" and $v = $v->($dbh);
167 209         543 return $v;
168             } # get_info
169              
170             sub type_info_all {
171             # my $dbh = shift;
172 1     1   4780 require DBD::CSV::TypeInfo;
173 1         8 return [@$DBD::CSV::TypeInfo::type_info_all];
174             } # type_info_all
175              
176             # --- STATEMENT ----------------------------------------------------------------
177              
178             package DBD::CSV::st;
179              
180 23     23   196 use strict;
  23         43  
  23         1550  
181              
182             our $imp_data_size = 0;
183             our @ISA = qw( DBD::File::st );
184              
185             package DBD::CSV::Statement;
186              
187 23     23   163 use strict;
  23         58  
  23         655  
188 23     23   139 use Carp;
  23         42  
  23         2252  
189              
190             our @ISA = qw( DBD::File::Statement );
191              
192             package DBD::CSV::Table;
193              
194 23     23   185 use strict;
  23         66  
  23         998  
195 23     23   131 use Carp;
  23         258  
  23         32186  
196              
197             our @ISA = qw( DBD::File::Table );
198              
199             my %compat_map;
200              
201             { my %class_mapped;
202              
203             sub _register_compat_map {
204 6092     6092   10124 my $class = shift;
205              
206 6092         7992 my $x = 0;
207 6092 100       12844 if (!%compat_map) {
208 22         324 $compat_map{$_} = "f_$_" for @f_SHORT;
209 22         576 $compat_map{$_} = "csv_$_" for @c_SHORT;
210 22         67 $x++;
211             }
212 6092 100 66     22374 if ($class and !$class_mapped{$class}++ and
      66        
213 22         188 my @ka = eval { $class->known_attributes }) {
214             # exclude types
215 22         1530 $compat_map{$_} = "csv_$_" for grep m/^[a-su-z]/ => @ka;
216 22         76 $x++;
217             }
218 6092 100       12364 if ($x) {
219 22         242 __PACKAGE__->register_compat_map (\%compat_map);
220             }
221             } # _register_compat_map
222             }
223              
224             #sub DESTROY {
225             # my $self = shift or return;
226             #
227             # $self->{meta} and delete $self->{meta}{csv_in};
228             # } # DESTROY
229              
230             sub bootstrap_table_meta {
231 5785     5785   5139962 my ($self, $dbh, $meta, $table) = @_;
232 5785   50     39097 $meta->{csv_class} ||= $dbh->{csv_class} || "Text::CSV_XS";
      66        
233 5785   100     26527 $meta->{csv_eol} ||= $dbh->{csv_eol} || "\r\n";
      66        
234              
235 5785         13031 _register_compat_map ($meta->{csv_class});
236              
237             exists $meta->{csv_skip_first_row} or
238 5785 100       13219 $meta->{csv_skip_first_row} = $dbh->{csv_skip_first_row};
239             exists $meta->{csv_bom} or
240 5785 50       17693 $meta->{csv_bom} = exists $dbh->{bom} ? $dbh->{bom} : $dbh->{csv_bom};
    100          
241 5785         15725 $self->SUPER::bootstrap_table_meta ($dbh, $meta, $table);
242             } # bootstrap_table_meta
243              
244             sub init_table_meta {
245 287     287   242600 my ($self, $dbh, $meta, $table) = @_;
246              
247 287         1026 _register_compat_map ($meta->{csv_class});
248              
249 287         1507 $self->SUPER::init_table_meta ($dbh, $table, $meta);
250              
251 287   66     2186 my $csv_in = $meta->{csv_in} || $dbh->{csv_csv_in};
252 287 100       748 unless ($csv_in) {
253 271         1085 my %opts = ( binary => 1, auto_diag => 1 );
254              
255             # Allow specific Text::CSV_XS options
256 271         464 foreach my $attr (@{$dbh->{csv_xs_valid_attrs}}) {
  271         858  
257 6389 100       9365 $attr eq "eol" and next; # Handles below
258 6118 100       11966 exists $dbh->{"csv_$attr"} and $opts{$attr} = $dbh->{"csv_$attr"};
259             }
260             $dbh->{csv_null} || $meta->{csv_null} and
261             $opts{Text::CSV_XS->version < 1.18 ? "always_quote" : "quote_empty"} =
262 271 50 66     1548 $opts{blank_is_undef} = 1;
    100          
263              
264 271         650 my $class = $meta->{csv_class};
265 271         492 my $eol = $meta->{csv_eol};
266 271 50       1240 $eol =~ m/^\A(?:[\r\n]|\r\n)\Z/ or $opts{eol} = $eol;
267 271         1285 for ([ "sep", ',' ],
268             [ "quote", '"' ],
269             [ "escape", '"' ],
270             ) {
271 813         1956 my ($attr, $def) = ($_->[0]."_char", $_->[1]);
272             $opts{$attr} =
273             exists $meta->{$attr} ? $meta->{$attr} :
274 813 100       3192 exists $dbh->{"csv_$attr"} ? $dbh->{"csv_$attr"} : $def;
    50          
275             }
276 271 50       2112 $meta->{csv_in} = $class->new (\%opts) or
277             $class->error_diag;
278 271         54134 $opts{eol} = $eol;
279 271 50       966 $meta->{csv_out} = $class->new (\%opts) or
280             $class->error_diag;
281             }
282             } # init_table_meta
283              
284             sub table_meta_attr_changed {
285 20     20   4615 my ($class, $meta, $attr, $value) = @_;
286              
287 20         49 _register_compat_map ($meta->{csv_class});
288              
289 20         42 (my $csv_attr = $attr) =~ s/^csv_//;
290 20 100       39 if (exists $csv_xs_attr{$csv_attr}) {
291 3         10 for ("csv_in", "csv_out") {
292             exists $meta->{$_} && exists $meta->{$_}{$csv_attr} and
293 6 50 33     31 $meta->{$_}{$csv_attr} = $value;
294             }
295             }
296              
297 20         60 $class->SUPER::table_meta_attr_changed ($meta, $attr, $value);
298             } # table_meta_attr_changed
299              
300             sub open_data {
301 433     433   1392462 my ($self, $meta, $attrs, $flags) = @_;
302 433         1832 $self->SUPER::open_file ($meta, $attrs, $flags);
303              
304 423 50 33     125457 if ($meta && $meta->{fh}) {
305 423         1296 $attrs->{csv_csv_in} = $meta->{csv_in};
306 423         969 $attrs->{csv_csv_out} = $meta->{csv_out};
307 423 100       1318 if (my $types = $meta->{types}) {
308             # XXX $meta->{types} is nowhere assigned and should better $meta->{csv_types}
309             # The 'types' array contains DBI types, but we need types
310             # suitable for Text::CSV_XS.
311 2         5 my $t = [];
312 2         5 for (@{$types}) {
  2         10  
313 6 100 66     24 $_ = $_
314             ? $DBD::CSV::dr::CSV_TYPES[$_ + 6] || Text::CSV_XS::PV ()
315             : Text::CSV_XS::PV ();
316 6         21 push @$t, $_;
317             }
318 2         5 $meta->{types} = $t;
319             }
320 423 100       1348 if (!$flags->{createMode}) {
321 395         694 my $array;
322             my $skipRows = defined $meta->{skip_rows}
323             ? $meta->{skip_rows}
324             : defined $meta->{csv_skip_first_row}
325             ? 1
326 395 100       1941 : exists $meta->{col_names} ? 0 : 1;
    50          
    100          
327             defined $meta->{skip_rows} or
328 395 100       1201 $meta->{skip_rows} = $skipRows;
329 395 50       1113 if ($meta->{csv_bom}) {
330             my @hdr = $attrs->{csv_csv_in}->header ($meta->{fh}) or
331 0 0       0 croak "Failed using the header row: ".$attrs->{csv_csv_in}->error_diag;
332 0   0     0 $meta->{col_names} ||= \@hdr;
333 0 0       0 $skipRows and $skipRows = 0;
334             }
335 395 100       1149 if ($skipRows--) {
336             $array = $attrs->{csv_csv_in}->getline ($meta->{fh}) or
337 389 50       18076 croak "Missing first row due to ".$attrs->{csv_csv_in}->error_diag;
338 389 50       29839 unless ($meta->{raw_header}) {
339 389         2007 s/\W/_/g for @$array;
340             }
341             defined $meta->{col_names} or
342 389 100       1332 $meta->{col_names} = $array;
343 389         1205 while ($skipRows--) {
344 12         349 $attrs->{csv_csv_in}->getline ($meta->{fh});
345             }
346             }
347             # lockMode is set 1 for DELETE, INSERT or UPDATE
348             # no other case need seeking
349             $flags->{lockMode} and # $meta->{fh}->can ("tell") and
350 395 100       1848 $meta->{first_row_pos} = $meta->{fh}->tell ();
351             exists $meta->{col_names} and
352 395 50       1840 $array = $meta->{col_names};
353 395 100 66     1216 if (!$meta->{col_names} || !@{$meta->{col_names}}) {
354             # No column names given; fetch first row and create default
355             # names.
356             my $ar = $meta->{cached_row} =
357 1         47 $attrs->{csv_csv_in}->getline ($meta->{fh});
358 1         106 $array = $meta->{col_names};
359 1         6 push @$array, map { "col$_" } 0 .. $#$ar;
  4         13  
360             }
361             }
362             }
363             } # open_file
364              
365 23     23   202 no warnings 'once';
  23         45  
  23         1628  
366             $DBI::VERSION < 1.623 and
367             *open_file = \&open_data;
368 23     23   177 use warnings;
  23         55  
  23         11013  
369              
370             sub _csv_diag {
371 2     2   22 my @diag = $_[0]->error_diag;
372 2         55 for (2, 3) {
373 4 50       13 defined $diag[$_] or $diag[$_] = "?";
374             }
375 2         8 return @diag;
376             } # _csv_diag
377              
378             sub fetch_row {
379 1177     1177   290537 my ($self, $data) = @_;
380              
381 1177         1895 my $tbl = $self->{meta};
382              
383             exists $tbl->{cached_row} and
384 1177 100       2690 return $self->{row} = delete $tbl->{cached_row};
385              
386             my $csv = $self->{csv_csv_in} or
387 1176 50       2597 return do { $data->set_err ($DBI::stderr, "Fetch from undefined handle"); undef };
  0         0  
  0         0  
388              
389 1176         1587 my $fields = eval { $csv->getline ($tbl->{fh}) };
  1176         28848  
390 1176 100       46467 unless ($fields) {
391 285 100       1676 $csv->eof and return;
392              
393 2         22 my @diag = _csv_diag ($csv);
394 2 50       7 $diag[0] == 2012 and return; # Also EOF (broken in Text::CSV_XS-1.10)
395              
396 2         7 my $file = $tbl->{f_fqfn};
397 2         550 croak "Error $diag[0] while reading file $file: $diag[1] \@ line $diag[3] pos $diag[2]";
398             }
399 891         2313 @$fields < @{$tbl->{col_names}} and
400 891 50       1373 push @$fields, (undef) x (@{$tbl->{col_names}} - @$fields);
  0         0  
401 891 50       3617 $self->{row} = (@$fields ? $fields : undef);
402             } # fetch_row
403              
404             sub push_row {
405 187     187   60295 my ($self, $data, $fields) = @_;
406 187         359 my $tbl = $self->{meta};
407 187         293 my $csv = $self->{csv_csv_out};
408 187         286 my $fh = $tbl->{fh};
409              
410 187 50       1689 unless ($csv->print ($fh, $fields)) {
411 0         0 my @diag = _csv_diag ($csv);
412 0         0 my $file = $tbl->{f_fqfn};
413 0         0 return do { $data->set_err ($DBI::stderr,
  0         0  
414 0         0 "Error $diag[0] while writing file $file: $diag[1] \@ line $diag[3] pos $diag[2]"); undef };
415             }
416 187         2670 1;
417             } # push_row
418              
419 23     23   182 no warnings 'once';
  23         56  
  23         1260  
420             *push_names = \&push_row;
421 23     23   159 use warnings;
  23         41  
  23         1454  
422              
423             1;
424              
425             __END__