File Coverage

blib/lib/DBD/CSV.pm
Criterion Covered Total %
statement 207 218 94.9
branch 78 110 70.9
condition 25 41 60.9
subroutine 31 32 96.8
pod n/a
total 341 401 85.0


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 24     24   3659148 use strict;
  24         66  
  24         798  
12 24     24   160 use warnings;
  24         69  
  24         2442  
13              
14             require DynaLoader;
15             require DBD::File;
16             require IO::File;
17              
18             our @f_SHORT = qw( class file dir dir_search ext lock lockfile schema encoding );
19             our @c_SHORT = qw( 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 24     24   219 use strict;
  24         60  
  24         686  
29              
30 24     24   155 use vars qw( @ISA $VERSION $ATTRIBUTION $drh $err $errstr $sqlstate );
  24         61  
  24         4119  
31              
32             @ISA = qw( DBD::File );
33              
34             $VERSION = "0.60";
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 24     24   210 use strict;
  24         81  
  24         1421  
50              
51 24     24   1193 use Text::CSV_XS ();
  24         20486  
  24         659  
52 24     24   132 use vars qw( @ISA @CSV_TYPES );
  24         67  
  24         8580  
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 259     259   680419 my ($drh, $dbname, $user, $auth, $attr) = @_;
79 259 50 33     1706 if ($attr && ref $attr eq "HASH") {
80             # Top-level aliasses
81 259         793 foreach my $key (grep { exists $attr->{$_} } @f_SHORT) {
  2331         4862  
82 3         7 my $f_key = "f_$key";
83 3 50       9 exists $attr->{$f_key} and next;
84 3         8 $attr->{$f_key} = delete $attr->{$key};
85             }
86 259         914 foreach my $key (grep { exists $attr->{$_} } @c_SHORT) {
  5698         9638  
87 3         6 my $c_key = "csv_$key";
88 3 50       7 exists $attr->{$c_key} and next;
89 3         7 $attr->{$c_key} = delete $attr->{$key};
90             }
91             }
92              
93 259         1807 my $dbh = $drh->DBD::File::dr::connect ($dbname, $user, $auth, $attr);
94 259 50       256727 $dbh and $dbh->{Active} = 1;
95 259         2955 $dbh;
96             } # connect
97              
98             # --- DATABASE -----------------------------------------------------------------
99              
100             package DBD::CSV::db;
101              
102 24     24   191 use strict;
  24         65  
  24         16080  
103              
104             our $imp_data_size = 0;
105             our @ISA = qw( DBD::File::db );
106              
107             sub set_versions {
108 259     259   11273 my $this = shift;
109 259         713 $this->{csv_version} = $DBD::CSV::VERSION;
110 259         950 return $this->SUPER::set_versions ();
111             } # set_versions
112              
113             my %csv_xs_attr;
114              
115             sub init_valid_attributes {
116 259     259   27736 my $dbh = shift;
117              
118             # Straight from Text::CSV_XS.pm
119 259         1413 my @xs_attr = @c_SHORT;
120 259         1990 @csv_xs_attr{@xs_attr} = ();
121             # Dynamically add "new" attributes - available in Text::CSV_XS-1.20
122 259 50       638 if (my @ka = eval { Text::CSV_XS->known_attributes }) {
  259         1776  
123 259 100       10768 for (grep { m/^[a-su-z]/ && !exists $csv_xs_attr{$_} } @ka) {
  8029         25044  
124 192         327 push @xs_attr => $_;
125 192         365 $csv_xs_attr{$_} = undef;
126             }
127             };
128              
129 259         1525 $dbh->{csv_xs_valid_attrs} = [ @xs_attr ];
130              
131 259         799 $dbh->{csv_valid_attrs} = { map {("csv_$_" => 1 )} @xs_attr, qw(
  8998         18906  
132              
133             class tables in csv_in out csv_out skip_first_row
134              
135             null sep quote escape bom
136             )};
137              
138 259         1467 $dbh->{csv_readonly_attrs} = { };
139              
140 259         620 $dbh->{csv_meta} = "csv_tables";
141              
142 259         1111 return $dbh->SUPER::init_valid_attributes ();
143             } # init_valid_attributes
144              
145             sub get_csv_versions {
146 1     1   316 my ($dbh, $table) = @_;
147 1   50     9 $table ||= "";
148 1         2 my $class = $dbh->{ImplementorClass};
149 1         4 $class =~ s/::db$/::Table/;
150 1         2 my $meta;
151 1 50       3 $table and (undef, $meta) = $class->get_table_meta ($dbh, $table, 1);
152 1 50       5 unless ($meta) {
153 1         2 $meta = {};
154 1         6 $class->bootstrap_table_meta ($dbh, $meta, $table);
155             }
156 1         77 my $dvsn = eval { $meta->{csv_class}->VERSION (); };
  1         10  
157 1         2 my $dtype = $meta->{csv_class};
158 1 50       5 $dvsn and $dtype .= " ($dvsn)";
159 1         8 return sprintf "%s using %s", $dbh->{csv_version}, $dtype;
160             } # get_csv_versions
161              
162             sub get_info {
163 209     209   301759 my ($dbh, $info_type) = @_;
164 209         4250 require DBD::CSV::GetInfo;
165 209         823 my $v = $DBD::CSV::GetInfo::info{int ($info_type)};
166 209 50       680 ref $v eq "CODE" and $v = $v->($dbh);
167 209         544 return $v;
168             } # get_info
169              
170             sub type_info_all {
171             # my $dbh = shift;
172 1     1   4582 require DBD::CSV::TypeInfo;
173 1         6 return [@$DBD::CSV::TypeInfo::type_info_all];
174             } # type_info_all
175              
176             # --- STATEMENT ----------------------------------------------------------------
177              
178             package DBD::CSV::st;
179              
180 24     24   207 use strict;
  24         56  
  24         1664  
181              
182             our $imp_data_size = 0;
183             our @ISA = qw( DBD::File::st );
184              
185             package DBD::CSV::Statement;
186              
187 24     24   181 use strict;
  24         56  
  24         610  
188 24     24   165 use Carp;
  24         56  
  24         2330  
189              
190             our @ISA = qw( DBD::File::Statement );
191              
192             package DBD::CSV::Table;
193              
194 24     24   168 use strict;
  24         93  
  24         1055  
195 24     24   148 use Carp;
  24         327  
  24         34733  
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 6301     6301   9254 my $class = shift;
205              
206 6301         8183 my $x = 0;
207 6301 100       12094 if (!%compat_map) {
208 23         356 $compat_map{$_} = "f_$_" for @f_SHORT;
209 23         530 $compat_map{$_} = "csv_$_" for @c_SHORT;
210 23         64 $x++;
211             }
212 6301 100 66     23299 if ($class and !$class_mapped{$class}++ and
      100        
213 25         183 my @ka = eval { $class->known_attributes }) {
214             # exclude types
215 23         1623 $compat_map{$_} = "csv_$_" for grep m/^[a-su-z]/ => @ka;
216 23         63 $x++;
217             }
218 6301 100       13929 if ($x) {
219 23         251 __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 5990     5990   5301245 my ($self, $dbh, $meta, $table) = @_;
232 5990   100     38028 $meta->{csv_class} ||= $dbh->{csv_class} || "Text::CSV_XS";
      66        
233 5990   100     26322 $meta->{csv_eol} ||= $dbh->{csv_eol} || "\r\n";
      66        
234              
235 5990         13792 _register_compat_map ($meta->{csv_class});
236              
237             exists $meta->{csv_skip_first_row} or
238 5990 100       14538 $meta->{csv_skip_first_row} = $dbh->{csv_skip_first_row};
239             exists $meta->{csv_bom} or
240 5990 50       16412 $meta->{csv_bom} = exists $dbh->{bom} ? $dbh->{bom} : $dbh->{csv_bom};
    100          
241 5990         15987 $self->SUPER::bootstrap_table_meta ($dbh, $meta, $table);
242             } # bootstrap_table_meta
243              
244             sub init_table_meta {
245 291     291   242986 my ($self, $dbh, $meta, $table) = @_;
246              
247 291         892 _register_compat_map ($meta->{csv_class});
248              
249 291         1352 $self->SUPER::init_table_meta ($dbh, $table, $meta);
250              
251 291   66     2079 my $csv_in = $meta->{csv_in} || $dbh->{csv_csv_in};
252 291 100       716 unless ($csv_in) {
253 275         1024 my %opts = ( binary => 1, auto_diag => 1 );
254              
255             # Allow specific Text::CSV_XS options
256 275         536 foreach my $attr (@{$dbh->{csv_xs_valid_attrs}}) {
  275         778  
257 6266 100       9773 $attr eq "eol" and next; # Handles below
258 5991 100       12319 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 275 50 66     1848 $opts{blank_is_undef} = 1;
    100          
263              
264 275         673 my $class = $meta->{csv_class};
265 275         500 my $eol = $meta->{csv_eol};
266 275 50       1375 $eol =~ m/^\A(?:[\r\n]|\r\n)\Z/ or $opts{eol} = $eol;
267 275         1298 for ([ "sep", ',' ],
268             [ "quote", '"' ],
269             [ "escape", '"' ],
270             ) {
271 825         2144 my ($attr, $def) = ($_->[0]."_char", $_->[1]);
272             $opts{$attr} =
273             exists $meta->{$attr} ? $meta->{$attr} :
274 825 100       3104 exists $dbh->{"csv_$attr"} ? $dbh->{"csv_$attr"} : $def;
    50          
275             }
276 275 50       2211 $meta->{csv_in} = $class->new (\%opts) or
277             $class->error_diag;
278 273         52879 $opts{eol} = $eol;
279 273 50       923 $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   5345 my ($class, $meta, $attr, $value) = @_;
286              
287 20         54 _register_compat_map ($meta->{csv_class});
288              
289 20         50 (my $csv_attr = $attr) =~ s/^csv_//;
290 20 100       48 if (exists $csv_xs_attr{$csv_attr}) {
291 3         8 for ("csv_in", "csv_out") {
292             exists $meta->{$_} && exists $meta->{$_}{$csv_attr} and
293 6 50 33     36 $meta->{$_}{$csv_attr} = $value;
294             }
295             }
296              
297 20         83 $class->SUPER::table_meta_attr_changed ($meta, $attr, $value);
298             } # table_meta_attr_changed
299              
300             sub open_data {
301 437     437   1353536 my ($self, $meta, $attrs, $flags) = @_;
302 437         1760 $self->SUPER::open_file ($meta, $attrs, $flags);
303              
304 427 50 33     107526 if ($meta && $meta->{fh}) {
305 427         1175 $attrs->{csv_csv_in} = $meta->{csv_in};
306 427         846 $attrs->{csv_csv_out} = $meta->{csv_out};
307 427 100       1309 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         11 my $t = [];
312 2         5 for (@{$types}) {
  2         5  
313 6 100 66     24 $_ = $_
314             ? $DBD::CSV::dr::CSV_TYPES[$_ + 6] || Text::CSV_XS::PV ()
315             : Text::CSV_XS::PV ();
316 6         20 push @$t, $_;
317             }
318 2         16 $meta->{types} = $t;
319             }
320 427 100       1261 if (!$flags->{createMode}) {
321 397         672 my $array;
322             my $skipRows = defined $meta->{skip_rows}
323             ? $meta->{skip_rows}
324             : defined $meta->{csv_skip_first_row}
325             ? 1
326 397 100       1707 : exists $meta->{col_names} ? 0 : 1;
    50          
    100          
327             defined $meta->{skip_rows} or
328 397 100       1263 $meta->{skip_rows} = $skipRows;
329 397 50       1153 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 397 100       1107 if ($skipRows--) {
336             $array = $attrs->{csv_csv_in}->getline ($meta->{fh}) or
337 391 50       16523 croak "Missing first row due to ".$attrs->{csv_csv_in}->error_diag;
338 391 50       30068 unless ($meta->{raw_header}) {
339 391         1933 s/\W/_/g for @$array;
340             }
341             defined $meta->{col_names} or
342 391 100       1416 $meta->{col_names} = $array;
343 391         1103 while ($skipRows--) {
344 12         426 $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 397 100       1609 $meta->{first_row_pos} = $meta->{fh}->tell ();
351             exists $meta->{col_names} and
352 397 50       1725 $array = $meta->{col_names};
353 397 100 66     1136 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         43 $attrs->{csv_csv_in}->getline ($meta->{fh});
358 1         67 $array = $meta->{col_names};
359 1         6 push @$array, map { "col$_" } 0 .. $#$ar;
  4         13  
360             }
361             }
362             }
363             } # open_file
364              
365 24     24   206 no warnings 'once';
  24         55  
  24         1598  
366             $DBI::VERSION < 1.623 and
367             *open_file = \&open_data;
368 24     24   199 use warnings;
  24         69  
  24         11878  
369              
370             sub _csv_diag {
371 2     2   8 my @diag = $_[0]->error_diag;
372 2         48 for (2, 3) {
373 4 50       33 defined $diag[$_] or $diag[$_] = "?";
374             }
375 2         7 return @diag;
376             } # _csv_diag
377              
378             sub fetch_row {
379 1177     1177   280454 my ($self, $data) = @_;
380              
381 1177         1962 my $tbl = $self->{meta};
382              
383             exists $tbl->{cached_row} and
384 1177 100       2699 return $self->{row} = delete $tbl->{cached_row};
385              
386             my $csv = $self->{csv_csv_in} or
387 1176 50       2543 return do { $data->set_err ($DBI::stderr, "Fetch from undefined handle"); undef };
  0         0  
  0         0  
388              
389 1176         1642 my $fields = eval { $csv->getline ($tbl->{fh}) };
  1176         28121  
390 1176 100       46588 unless ($fields) {
391 285 100       1602 $csv->eof and return;
392              
393 2         19 my @diag = _csv_diag ($csv);
394 2 50       10 $diag[0] == 2012 and return; # Also EOF (broken in Text::CSV_XS-1.10)
395              
396 2         5 my $file = $tbl->{f_fqfn};
397 2         537 croak "Error $diag[0] while reading file $file: $diag[1] \@ line $diag[3] pos $diag[2]";
398             }
399 891         2112 @$fields < @{$tbl->{col_names}} and
400 891 50       1453 push @$fields, (undef) x (@{$tbl->{col_names}} - @$fields);
  0         0  
401 891 50       3322 $self->{row} = (@$fields ? $fields : undef);
402             } # fetch_row
403              
404             sub push_row {
405 189     189   59060 my ($self, $data, $fields) = @_;
406 189         342 my $tbl = $self->{meta};
407 189         299 my $csv = $self->{csv_csv_out};
408 189         268 my $fh = $tbl->{fh};
409              
410 189 50       1572 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 189         2740 1;
417             } # push_row
418              
419 24     24   225 no warnings 'once';
  24         58  
  24         1263  
420             *push_names = \&push_row;
421 24     24   169 use warnings;
  24         51  
  24         1482  
422              
423             1;
424              
425             __END__