Mercurial > hg > monetdb-perl

comparison DBD/monetdb.pm @ 0:cedccb7e0143

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Copy of clients/perl directory without Tests from MonetDB changeset 4d2d4532228a.
author Sjoerd Mullender <sjoerd@acm.org>
date Mon, 19 Sep 2016 15:15:52 +0200 (2016-09-19)
parents
children f899cb48b4cc
comparison
equal deleted inserted replaced
-1:000000000000 0:cedccb7e0143
1 package DBD::monetdb;
2
3 use strict;
4 use DBI();
5 use Encode();
6 use MonetDB::CLI();
7
8 our $VERSION = '0.10';
9 our $drh = undef;
10
11 require DBD::monetdb::GetInfo;
12 require DBD::monetdb::TypeInfo;
13
14
15 sub driver {
16 return $drh if $drh;
17
18 my ($class, $attr) = @_;
19
20 $drh = DBI::_new_drh($class .'::dr', {
21 Name => 'monetdb',
22 Version => $VERSION,
23 Attribution => 'DBD::monetdb by Martin Kersten, Arjan Scherpenisse and Steffen Goeldner',
24 });
25 }
26
27
28 sub CLONE {
29 undef $drh;
30 }
31
32
33
34 package DBD::monetdb::dr;
35
36 $DBD::monetdb::dr::imp_data_size = 0;
37
38
39 sub connect {
40 my ($drh, $dsn, $user, $password, $attr) = @_;
41
42 my %dsn;
43 for ( split /;|:/, $dsn ||'') {
44 if ( my ( $k, $v ) = /(.*?)=(.*)/) {
45 $k = 'host' if $k eq 'hostname';
46 $k = 'database' if $k eq 'dbname' || $k eq 'db';
47 $dsn{$k} = $v;
48 next;
49 }
50 for my $k ( qw(host port database language) ) {
51 $dsn{$k} = $_, last unless defined $dsn{$k};
52 }
53 }
54 my $lang = $dsn{language} || 'sql';
55 my $host = $dsn{host} || 'localhost';
56 my $port = $dsn{port} || 50000;
57 $user ||= 'monetdb';
58 $password ||= 'monetdb';
59 my $db = $dsn{database} || 'demo';
60
61 my $cxn = eval { MonetDB::CLI->connect($host, $port, $user, $password, $lang, $db) };
62 return $drh->set_err(-1, $@) if $@;
63
64 my ($outer, $dbh) = DBI::_new_dbh($drh, { Name => $dsn });
65
66 $dbh->STORE('Active', 1 );
67
68 $dbh->{monetdb_connection} = $cxn;
69 $dbh->{monetdb_language} = $lang;
70
71 return $outer;
72 }
73
74
75 sub data_sources {
76 return ('dbi:monetdb:');
77 }
78
79
80
81 package DBD::monetdb::db;
82
83 $DBD::monetdb::db::imp_data_size = 0;
84
85
86 sub ping {
87 my ($dbh) = @_;
88
89 my $statement = $dbh->{monetdb_language} eq 'sql' ? 'select 7' : 'io.print(7);';
90 my $rv = $dbh->selectrow_array($statement) || 0;
91 $dbh->set_err(undef, undef);
92 $rv == 7 ? 1 : 0;
93 }
94
95
96 sub quote {
97 my ($dbh, $value, $type) = @_;
98
99 return $dbh->{monetdb_language} eq 'sql' ? 'NULL' : 'nil'
100 unless defined $value;
101
102 $value = Encode::encode_utf8($value);
103
104 for ($value) {
105 s/\\/\\\\/g;
106 s/\n/\\n/g;
107 s/"/\\"/g;
108 s/'/''/g;
109 }
110
111 $type ||= DBI::SQL_VARCHAR();
112
113 my $prefix = $DBD::monetdb::TypeInfo::prefixes{$type} || '';
114 my $suffix = $DBD::monetdb::TypeInfo::suffixes{$type} || '';
115
116 if ( $dbh->{monetdb_language} ne 'sql') {
117 $prefix = q(") if $prefix eq q(');
118 $suffix = q(") if $suffix eq q(');
119 }
120 return $prefix . $value . $suffix;
121 }
122
123
124 sub _count_param {
125 my $statement = shift;
126 my $num = 0;
127
128 $statement =~ s{
129 ' (?: \\. | [^\\']++ )*+ ' |
130 " (?: \\. | [^\\"]++ )*+ '
131 }{}gx;
132
133 return $statement =~ tr/?/?/;
134 }
135
136
137 sub prepare {
138 my ($dbh, $statement, $attr) = @_;
139
140 my $cxn = $dbh->{monetdb_connection};
141 my $hdl = eval { $cxn->new_handle };
142 return $dbh->set_err(-1, $@) if $@;
143
144 my ($outer, $sth) = DBI::_new_sth($dbh, { Statement => $statement });
145
146 $sth->STORE('NUM_OF_PARAMS', _count_param($statement));
147
148 $sth->{monetdb_hdl} = $hdl;
149 $sth->{monetdb_params} = [];
150 $sth->{monetdb_types} = [];
151 $sth->{monetdb_rows} = -1;
152
153 return $outer;
154 }
155
156
157 sub commit {
158 my($dbh) = @_;
159
160 if ($dbh->FETCH('AutoCommit')) {
161 warn 'Commit ineffective while AutoCommit is on' if $dbh->FETCH('Warn');
162 return 0;
163 }
164 if ($dbh->{monetdb_language} eq 'sql') {
165 return $dbh->do('commit')
166 && $dbh->do('start transaction');
167 }
168 else {
169 return $dbh->do('commit();');
170 }
171 }
172
173
174 sub rollback {
175 my($dbh) = @_;
176
177 if ($dbh->FETCH('AutoCommit')) {
178 warn 'Rollback ineffective while AutoCommit is on' if $dbh->FETCH('Warn');
179 return 0;
180 }
181 if ($dbh->{monetdb_language} eq 'sql') {
182 return $dbh->do('rollback')
183 && $dbh->do('start transaction');
184 }
185 else {
186 return $dbh->do('abort();');
187 }
188 }
189
190
191 *get_info = \&DBD::monetdb::GetInfo::get_info;
192
193
194 sub monetdb_catalog_info {
195 my($dbh) = @_;
196 my $sql = <<'SQL';
197 select cast( null as varchar( 128 ) ) as table_cat
198 , cast( null as varchar( 128 ) ) as table_schem
199 , cast( null as varchar( 128 ) ) as table_name
200 , cast( null as varchar( 254 ) ) as table_type
201 , cast( null as varchar( 254 ) ) as remarks
202 where 0 = 1
203 order by table_cat
204 SQL
205 my $sth = $dbh->prepare($sql) or return;
206 $sth->execute or return;
207 return $sth;
208 }
209
210
211 sub monetdb_schema_info {
212 my($dbh) = @_;
213 my $sql = <<'SQL';
214 select cast( null as varchar( 128 ) ) as table_cat
215 , "name" as table_schem
216 , cast( null as varchar( 128 ) ) as table_name
217 , cast( null as varchar( 254 ) ) as table_type
218 , cast( null as varchar( 254 ) ) as remarks
219 from sys."schemas"
220 order by table_schem
221 SQL
222 my $sth = $dbh->prepare($sql) or return;
223 $sth->execute or return;
224 return $sth;
225 }
226
227
228 my $ttp = {
229 'TABLE' => 't."type" = 0 and t."system" = false and t."temporary" = 0 and s.name <> \'tmp\''
230 ,'GLOBAL TEMPORARY' => 't."type" = 0 and t."system" = false and t."temporary" = 0 and s.name = \'tmp\''
231 ,'SYSTEM TABLE' => 't."type" = 0 and t."system" = true and t."temporary" = 0'
232 ,'LOCAL TEMPORARY' => 't."type" = 0 and t."system" = false and t."temporary" = 1'
233 ,'VIEW' => 't."type" = 1 '
234 };
235
236
237 sub monetdb_tabletype_info {
238 my($dbh) = @_;
239 my $sql = <<"SQL";
240 select distinct
241 cast( null as varchar( 128 ) ) as table_cat
242 , cast( null as varchar( 128 ) ) as table_schem
243 , cast( null as varchar( 128 ) ) as table_name
244 , case
245 when $ttp->{'TABLE' } then cast('TABLE' as varchar( 254 ) )
246 when $ttp->{'SYSTEM TABLE' } then cast('SYSTEM TABLE' as varchar( 254 ) )
247 when $ttp->{'LOCAL TEMPORARY' } then cast('LOCAL TEMPORARY' as varchar( 254 ) )
248 when $ttp->{'GLOBAL TEMPORARY'} then cast('GLOBAL TEMPORARY' as varchar( 254 ) )
249 when $ttp->{'VIEW' } then cast('VIEW' as varchar( 254 ) )
250 else cast('INTERNAL TABLE TYPE' as varchar( 254 ) )
251 end as table_type
252 , cast( null as varchar( 254 ) ) as remarks
253 from sys."tables" t, sys."schemas" s
254 where t."schema_id" = s."id"
255 order by table_type
256 SQL
257 my $sth = $dbh->prepare($sql) or return;
258 $sth->execute or return;
259 return $sth;
260 }
261
262
263 sub monetdb_table_info {
264 my($dbh, $c, $s, $t, $tt) = @_;
265 my $sql = <<"SQL";
266 select cast( null as varchar( 128 ) ) as table_cat
267 , s."name" as table_schem
268 , t."name" as table_name
269 , case
270 when $ttp->{'TABLE' } then cast('TABLE' as varchar( 254 ) )
271 when $ttp->{'SYSTEM TABLE' } then cast('SYSTEM TABLE' as varchar( 254 ) )
272 when $ttp->{'LOCAL TEMPORARY' } then cast('LOCAL TEMPORARY' as varchar( 254 ) )
273 when $ttp->{'GLOBAL TEMPORARY'} then cast('GLOBAL TEMPORARY' as varchar( 254 ) )
274 when $ttp->{'VIEW' } then cast('VIEW' as varchar( 254 ) )
275 else cast('INTERNAL TABLE TYPE' as varchar( 254 ) )
276 end as table_type
277 , cast( null as varchar( 254 ) ) as remarks
278 from sys."schemas" s
279 , sys."tables" t
280 where t."schema_id" = s."id"
281 SQL
282 my @bv = ();
283 $sql .= qq( and s."name" like ?\n), push @bv, $s if $s;
284 $sql .= qq( and t."name" like ?\n), push @bv, $t if $t;
285 if ( @$tt ) {
286 $sql .= " and ( 1 = 0\n";
287 for ( @$tt ) {
288 my $p = $ttp->{uc $_};
289 $sql .= " or $p\n" if $p;
290 }
291 $sql .= " )\n";
292 }
293 $sql .= " order by table_type, table_schem, table_name\n";
294 my $sth = $dbh->prepare($sql) or return;
295 $sth->execute(@bv) or return;
296
297 $dbh->set_err(0,"Catalog parameter c has to be an empty string, as MonetDB does not support multiple catalogs") if $c ne "";
298 return $sth;
299 }
300
301
302 sub table_info {
303 my($dbh, $c, $s, $t, $tt) = @_;
304
305 if ( defined $c && defined $s && defined $t ) {
306 if ( $c eq '%' && $s eq '' && $t eq '') {
307 return monetdb_catalog_info($dbh);
308 }
309 elsif ( $c eq '' && $s eq '%' && $t eq '') {
310 return monetdb_schema_info($dbh);
311 }
312 elsif ( $c eq '' && $s eq '' && $t eq '' && defined $tt && $tt eq '%') {
313 return monetdb_tabletype_info($dbh);
314 }
315 }
316 my @tt;
317 if ( defined $tt ) {
318 @tt = split /,/, $tt;
319 s/^\s*'?//, s/'?\s*$// for @tt;
320 }
321 return monetdb_table_info($dbh, $c, $s, $t, \@tt);
322 }
323
324
325 sub column_info {
326 my($dbh, $catalog, $schema, $table, $column) = @_;
327 # TODO: test $catalog for equality with empty string
328 my $sql = <<'SQL';
329 select cast( null as varchar( 128 ) ) as table_cat
330 , s."name" as table_schem
331 , t."name" as table_name
332 , c."name" as column_name
333 , cast( 0 as smallint ) as data_type -- ...
334 , c."type" as type_name -- TODO
335 , cast( c."type_digits" as integer ) as column_size -- TODO
336 , cast( null as integer ) as buffer_length -- TODO
337 , cast( c."type_scale" as smallint ) as decimal_digits -- TODO
338 , cast( null as smallint ) as num_prec_radix -- TODO
339 , case c."null"
340 when false then cast( 0 as smallint ) -- SQL_NO_NULLS
341 when true then cast( 1 as smallint ) -- SQL_NULLABLE
342 end as nullable
343 , cast( null as varchar( 254 ) ) as remarks
344 , c."default" as column_def
345 , cast( 0 as smallint ) as sql_data_type -- ...
346 , cast( null as smallint ) as sql_datetime_sub -- ...
347 , cast( null as integer ) as char_octet_length -- TODO
348 , cast( c."number" + 1 as integer ) as ordinal_position
349 , case c."null"
350 when false then cast('NO' as varchar( 254 ) )
351 when true then cast('YES' as varchar( 254 ) )
352 end as is_nullable
353 from sys."schemas" s
354 , sys."tables" t
355 , sys."columns" c
356 where t."schema_id" = s."id"
357 and c."table_id" = t."id"
358 SQL
359 my @bv = ();
360 $sql .= qq( and s."name" like ?\n), push @bv, $schema if $schema;
361 $sql .= qq( and t."name" like ?\n), push @bv, $table if $table;
362 $sql .= qq( and c."name" like ?\n), push @bv, $column if $column;
363 $sql .= " order by table_cat, table_schem, table_name, ordinal_position\n";
364 my $sth = $dbh->prepare($sql) or return;
365 $sth->execute(@bv) or return;
366 $dbh->set_err(0,"Catalog parameter catalog has to be an empty string, as MonetDB does not support multiple catalogs") if $catalog ne "";
367 my $rows;
368 while ( my $row = $sth->fetch ) {
369 $row->[ 4] = $DBD::monetdb::TypeInfo::typeinfo{$row->[5]}->[ 1];
370 $row->[13] = $DBD::monetdb::TypeInfo::typeinfo{$row->[5]}->[15];
371 $row->[14] = $DBD::monetdb::TypeInfo::typeinfo{$row->[5]}->[16];
372 push @$rows, [ @$row ];
373 }
374 return DBI->connect('dbi:Sponge:','','', { RaiseError => 1 } )->prepare(
375 $sth->{Statement},
376 { rows => $rows, NAME => $sth->{NAME}, TYPE => $sth->{TYPE} }
377 );
378 }
379
380
381 sub primary_key_info {
382 my($dbh, $catalog, $schema, $table) = @_;
383 # TODO: test $catalog for equality with empty string
384 return $dbh->set_err(-1,'Undefined schema','HY009') unless defined $schema;
385 return $dbh->set_err(-1,'Undefined table' ,'HY009') unless defined $table;
386 my $sql = <<'SQL';
387 select cast( null as varchar( 128 ) ) as table_cat
388 , s."name" as table_schem
389 , t."name" as table_name
390 , c."name" as column_name
391 , cast( c."nr" + 1 as smallint ) as key_seq
392 , k."name" as pk_name
393 from sys."schemas" s
394 , sys."tables" t
395 , sys."keys" k
396 , sys."objects" c
397 where t."schema_id" = s."id"
398 and k."table_id" = t."id"
399 and c."id" = k."id"
400 and s."name" = ?
401 and t."name" = ?
402 and k."type" = 0
403 order by table_schem, table_name, key_seq
404 SQL
405 my $sth = $dbh->prepare($sql) or return;
406 $sth->execute($schema, $table) or return;
407 $dbh->set_err(0,"Catalog parameter catalog has to be an empty string, as MonetDB does not support multiple catalogs") if $catalog ne "";
408 return $sth;
409 }
410
411
412 sub foreign_key_info {
413 my($dbh, $c1, $s1, $t1, $c2, $s2, $t2) = @_;
414 my $sql = <<'SQL';
415 select cast( null as varchar( 128 ) ) as uk_table_cat
416 , uks."name" as uk_table_schem
417 , ukt."name" as uk_table_name
418 , ukc."name" as uk_column_name
419 , cast( null as varchar( 128 ) ) as fk_table_cat
420 , fks."name" as fk_table_schem
421 , fkt."name" as fk_table_name
422 , fkc."name" as fk_column_name
423 , cast( fkc."nr" + 1 as smallint ) as ordinal_position
424 , cast( 3 as smallint ) as update_rule -- SQL_NO_ACTION
425 , cast( 3 as smallint ) as delete_rule -- SQL_NO_ACTION
426 , fkk."name" as fk_name
427 , ukk."name" as uk_name
428 , cast( 7 as smallint ) as deferability -- SQL_NOT_DEFERRABLE
429 , case ukk."type"
430 when 0 then cast('PRIMARY' as varchar( 7 ) )
431 when 1 then cast('UNIQUE' as varchar( 7 ) )
432 else cast( ukk."type" as varchar( 7 ) )
433 end as unique_or_primary
434 from sys."schemas" uks
435 , sys."tables" ukt
436 , sys."keys" ukk
437 , sys."objects" ukc
438 , sys."schemas" fks
439 , sys."tables" fkt
440 , sys."keys" fkk
441 , sys."objects" fkc
442 where ukt."schema_id" = uks."id"
443 and ukk."table_id" = ukt."id"
444 and ukc."id" = ukk."id"
445 and fkt."schema_id" = fks."id"
446 and fkk."table_id" = fkt."id"
447 and fkc."id" = fkk."id"
448 -- and ukk."type" IN ( 0, 1 )
449 -- and fkk."type" = 2
450 -- and fkk."rkey" > -1
451 and fkk."rkey" = ukk."id"
452 and fkc."nr" = ukc."nr"
453 SQL
454 my @bv = ();
455 $sql .= qq( and uks."name" = ?\n), push @bv, $s1 if $s1;
456 $sql .= qq( and ukt."name" = ?\n), push @bv, $t1 if $t1;
457 $sql .= qq( and fks."name" = ?\n), push @bv, $s2 if $s2;
458 $sql .= qq( and fkt."name" = ?\n), push @bv, $t2 if $t2;
459 $sql .= qq( and ukk."type" = 0\n) if $t1 && !$t2;
460 $sql .= " order by uk_table_schem, uk_table_name, fk_table_schem, fk_table_name, ordinal_position\n";
461 my $sth = $dbh->prepare($sql) or return;
462 $sth->execute(@bv) or return;
463 $dbh->set_err(0,"Catalog parameters c1 and c2 have to be an empty strings, as MonetDB does not support multiple catalogs") if $c1 ne "" || $c2 ne "";
464 return $sth;
465 }
466
467
468 *type_info_all = \&DBD::monetdb::TypeInfo::type_info_all;
469
470
471 sub tables {
472 my ($dbh, @args) = @_;
473
474 # TODO: !! warn: 0 CLEARED by call to fetchall_arrayref method
475 return $dbh->SUPER::tables( @args ) if $dbh->{monetdb_language} eq 'sql';
476
477 return eval{ @{$dbh->selectcol_arrayref('ls();')} };
478 }
479
480
481 sub disconnect {
482 my ($dbh) = @_;
483
484 delete $dbh->{monetdb_connection};
485 $dbh->STORE('Active', 0 );
486 return 1;
487 }
488
489
490 sub FETCH {
491 my ($dbh, $key) = @_;
492
493 return $dbh->{$key} if $key =~ /^monetdb_/;
494 return $dbh->SUPER::FETCH($key);
495 }
496
497
498 sub STORE {
499 my ($dbh, $key, $value) = @_;
500
501 if ($key eq 'AutoCommit') {
502 return 1 if $dbh->{monetdb_language} ne 'sql';
503 my $old_value = $dbh->{$key};
504 if ($value && defined $old_value && !$old_value) {
505 $dbh->do('commit')
506 or return $dbh->set_err($dbh->err, $dbh->errstr);
507 }
508 elsif (!$value && (!defined $old_value || $old_value)) {
509 $dbh->do('start transaction')
510 or return $dbh->set_err($dbh->err, $dbh->errstr);
511 }
512 $dbh->{$key} = $value;
513 return 1;
514 }
515 elsif ($key =~ /^monetdb_/) {
516 $dbh->{$key} = $value;
517 return 1;
518 }
519 return $dbh->SUPER::STORE($key, $value);
520 }
521
522
523 sub DESTROY {
524 my ($dbh) = @_;
525
526 $dbh->disconnect if $dbh->FETCH('Active');
527 }
528
529
530
531 package DBD::monetdb::st;
532
533 $DBD::monetdb::st::imp_data_size = 0;
534
535
536 sub bind_param {
537 my ($sth, $index, $value, $attr) = @_;
538
539 $sth->{monetdb_params}[$index-1] = $value;
540 $sth->{monetdb_types}[$index-1] = ref $attr ? $attr->{TYPE} : $attr;
541 return 1;
542 }
543
544
545 sub execute {
546 my($sth, @bind_values) = @_;
547 my $statement = $sth->{Statement};
548 my $dbh = $sth->{Database};
549
550 $sth->STORE('Active', 0 ); # we don't need to call $sth->finish because
551 # mapi_query_handle() calls finish_handle()
552
553 $sth->bind_param($_, $bind_values[$_-1]) or return for 1 .. @bind_values;
554
555 my $params = $sth->{monetdb_params};
556 my $num_of_params = $sth->FETCH('NUM_OF_PARAMS');
557 return $sth->set_err(-1, @$params ." values bound when $num_of_params expected")
558 unless @$params == $num_of_params;
559
560 for ( 1 .. $num_of_params ) {
561 my $quoted_param = $dbh->quote($params->[$_-1], $sth->{monetdb_types}[$_-1]);
562 $statement =~ s/\?/$quoted_param/; # TODO: '?' inside quotes/comments
563 }
564 $sth->trace_msg(" -- Statement: $statement\n", 5);
565
566 my $hdl = $sth->{monetdb_hdl};
567 eval{ $hdl->query($statement) };
568 return $sth->set_err(-1, $@) if $@;
569
570 my $rows = $hdl->rows_affected;
571
572 if ( $dbh->{monetdb_language} eq 'sql' && $hdl->querytype != 1 ) {
573 $sth->{monetdb_rows} = $rows;
574 return $rows || '0E0';
575 }
576 my ( @names, @types, @precisions, @nullables );
577 my $field_count = $hdl->columncount;
578 for ( 0 .. $field_count-1 ) {
579 push @names , $hdl->name ($_);
580 push @types , $hdl->type ($_);
581 push @precisions, $hdl->length($_);
582 push @nullables , 2; # TODO
583 }
584 $sth->STORE('NUM_OF_FIELDS', $field_count) unless $sth->FETCH('NUM_OF_FIELDS');
585 $sth->{NAME} = \@names;
586 $sth->{TYPE} = [ map { $DBD::monetdb::TypeInfo::typeinfo{$_}->[1] } @types ];
587 $sth->{PRECISION} = \@precisions; # TODO
588 $sth->{SCALE} = [];
589 $sth->{NULLABLE} = \@nullables;
590 $sth->STORE('Active', 1 );
591
592 $sth->{monetdb_rows} = 0;
593
594 return $rows || '0E0';
595 }
596
597
598 sub fetch {
599 my ($sth) = @_;
600
601 return $sth->set_err(-900,'Statement handle not marked as Active')
602 unless $sth->FETCH('Active');
603 my $hdl = $sth->{monetdb_hdl};
604 my $field_count = eval{ $hdl->fetch };
605 unless ( $field_count ) {
606 $sth->STORE('Active', 0 );
607 $sth->set_err(-1, $@) if $@;
608 return;
609 }
610 my @row = map $hdl->{currow}[$_], 0 .. $field_count-1; # encapsulation break but saves a microsecond per cell
611 map { s/\s+$// } @row if $sth->FETCH('ChopBlanks');
612
613 $sth->{monetdb_rows}++;
614 return $sth->_set_fbav(\@row);
615 }
616
617 *fetchrow_arrayref = \&fetch;
618
619
620 sub rows {
621 my ($sth) = @_;
622
623 return $sth->{monetdb_rows};
624 }
625
626
627 sub finish {
628 my ($sth) = @_;
629 my $hdl = $sth->{monetdb_hdl};
630
631 eval{ $hdl->finish };
632 return $sth->set_err(-1, $@) if $@;
633
634 return $sth->SUPER::finish; # sets Active off
635 }
636
637
638 sub FETCH {
639 my ($sth, $key) = @_;
640
641 if ( $key =~ /^monetdb_/) {
642 return $sth->{$key};
643 }
644 elsif ( $key eq 'ParamValues') {
645 my $p = $sth->{monetdb_params};
646 return { map { $_ => $p->[$_-1] } 1 .. $sth->FETCH('NUM_OF_PARAMS') };
647 }
648 return $sth->SUPER::FETCH($key);
649 }
650
651
652 sub STORE {
653 my ($sth, $key, $value) = @_;
654
655 if ($key =~ /^monetdb_/) {
656 $sth->{$key} = $value;
657 return 1;
658 }
659 return $sth->SUPER::STORE($key, $value);
660 }
661
662
663 sub DESTROY {
664 my ($sth) = @_;
665
666 $sth->STORE('Active', 0 );
667 }
668
669
670 1;
671
672 __END__
673
674 =head1 NAME
675
676 DBD::monetdb - MonetDB Driver for DBI
677
678 =head1 SYNOPSIS
679
680 use DBI();
681
682 my $dbh = DBI->connect('dbi:monetdb:');
683
684 my $sth = $dbh->prepare('SELECT * FROM env() env');
685 $sth->execute;
686 $sth->dump_results;
687
688 =head1 DESCRIPTION
689
690 DBD::monetdb is a Pure Perl client interface for the MonetDB Database Server.
691 It requires MonetDB::CLI (and one of its implementations).
692
693 =head2 Outline Usage
694
695 From perl you activate the interface with the statement
696
697 use DBI;
698
699 After that you can connect to multiple MonetDB database servers
700 and send multiple queries to any of them via a simple object oriented
701 interface. Two types of objects are available: database handles and
702 statement handles. Perl returns a database handle to the connect
703 method like so:
704
705 $dbh = DBI->connect("dbi:monetdb:host=$host",
706 $user, $password, { RaiseError => 1 } );
707
708 Once you have connected to a database, you can can execute SQL
709 statements with:
710
711 my $sql = sprintf('INSERT INTO foo VALUES (%d, %s)',
712 $number, $dbh->quote('name'));
713 $dbh->do($sql);
714
715 See L<DBI> for details on the quote and do methods. An alternative
716 approach is
717
718 $dbh->do('INSERT INTO foo VALUES (?, ?)', undef, $number, $name);
719
720 in which case the quote method is executed automatically. See also
721 the bind_param method in L<DBI>.
722
723 If you want to retrieve results, you need to create a so-called
724 statement handle with:
725
726 $sth = $dbh->prepare("SELECT id, name FROM $table");
727 $sth->execute;
728
729 This statement handle can be used for multiple things. First of all
730 you can retreive a row of data:
731
732 my $row = $sth->fetch;
733
734 If your table has columns ID and NAME, then $row will be array ref with
735 index 0 and 1.
736
737 =head2 Example
738
739 #!/usr/bin/perl
740
741 use strict;
742 use DBI;
743
744 # Connect to the database.
745 my $dbh = DBI->connect('dbi:monetdb:host=localhost',
746 'joe', "joe's password", { RaiseError => 1 } );
747
748 # Drop table 'foo'. This may fail, if 'foo' doesn't exist.
749 # Thus we put an eval around it.
750 eval { $dbh->do('DROP TABLE foo') };
751 print "Dropping foo failed: $@\n" if $@;
752
753 # Create a new table 'foo'. This must not fail, thus we don't
754 # catch errors.
755 $dbh->do('CREATE TABLE foo (id INTEGER, name VARCHAR(20))');
756
757 # INSERT some data into 'foo'. We are using $dbh->quote() for
758 # quoting the name.
759 $dbh->do('INSERT INTO foo VALUES (1, ' . $dbh->quote('Tim') . ')');
760
761 # Same thing, but using placeholders
762 $dbh->do('INSERT INTO foo VALUES (?, ?)', undef, 2, 'Jochen');
763
764 # Now retrieve data from the table.
765 my $sth = $dbh->prepare('SELECT id, name FROM foo');
766 $sth->execute;
767 while ( my $row = $sth->fetch ) {
768 print "Found a row: id = $row->[0], name = $row->[1]\n";
769 }
770
771 # Disconnect from the database.
772 $dbh->disconnect;
773
774 =head1 METHODS
775
776 =head2 Driver Handle Methods
777
778 =over
779
780 =item B<connect>
781
782 use DBI();
783
784 $dsn = 'dbi:monetdb:';
785 $dsn = "dbi:monetdb:host=$host";
786 $dsn = "dbi:monetdb:host=$host;port=$port";
787 $dsn = "dbi:monetdb:host=$host;database=$database";
788
789 $dbh = DBI->connect($dsn, $user, $password);
790
791 =over
792
793 =item host
794
795 The default host to connect to is 'localhost', i.e. your workstation.
796
797 =item port
798
799 The port the MonetDB daemon listens to. Default for MonetDB is 50000.
800
801 =item database
802
803 The name of the database to connect to.
804
805 =back
806
807 =back
808
809 =head2 Database Handle Methods
810
811 The following methods are currently not supported:
812
813 last_insert_id
814
815 All MetaData methods are supported. However, column_info() currently doesn't
816 provide length (size, ...) related information.
817 The foreign_key_info() method returns a SQL/CLI like result set,
818 because it provides additional information about unique keys.
819
820 =head2 Statement Handle Methods
821
822 The following methods are currently not supported:
823
824 bind_param_inout
825 more_results
826 blob_read
827
828 =head1 ATTRIBUTES
829
830 The following attributes are currently not supported:
831
832 LongReadLen
833 LongTruncOk
834
835 =head2 Database Handle Attributes
836
837 The following attributes are currently not supported:
838
839 RowCacheSize
840
841 =head2 Statement Handle Attributes
842
843 The following attributes are currently not (or not correctly) supported:
844
845 PRECISION (MonetDB semantic != DBI semantic)
846 SCALE (empty)
847 NULLABLE (SQL_NULLABLE_UNKNOWN = 2)
848 CursorName
849 RowsInCache
850
851 =head1 AUTHORS
852
853 Martin Kersten E<lt>Martin.Kersten@cwi.nlE<gt> implemented the initial Mapi
854 based version of the driver (F<monet.pm>).
855 Arjan Scherpenisse E<lt>acscherp@science.uva.nlE<gt> renamed this module to
856 F<monetdbPP.pm> and derived the new MapiLib based version (F<monetdb.pm>).
857 Current maintainer is Steffen Goeldner E<lt>sgoeldner@cpan.orgE<gt>.
858
859 =head1 COPYRIGHT AND LICENCE
860
861 This Source Code Form is subject to the terms of the Mozilla Public
862 License, v. 2.0. If a copy of the MPL was not distributed with this
863 file, You can obtain one at http://mozilla.org/MPL/2.0/.
864
865 Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V.
866
867
868 Contributor(s): Steffen Goeldner.
869
870 =head1 SEE ALSO
871
872 =head2 MonetDB
873
874 Homepage : http://www.monetdb.org/
875
876 =head2 Perl modules
877
878 L<DBI>, L<MonetDB::CLI>
879
880 =cut