Mercurial > hg > monetdb-perl
changeset 0:cedccb7e0143
Copy of clients/perl directory without Tests from MonetDB changeset 4d2d4532228a.
line wrap: on
line diff
new file mode 100644 --- /dev/null +++ b/DBD/MANIFEST @@ -0,0 +1,31 @@ +Changes +MANIFEST +MANIFEST.SKIP +Makefile.PL +README +monetdb.pm +monetdb/GetInfo.pm +monetdb/TypeInfo.pm +t/01base.t +t/02ads.t +t/02cxn.t +t/05gi.t +t/06ti.t +t/07q.t +t/11prep.t +t/12bind.t +t/12ins_b.t +t/12ins_q.t +t/13count.t +t/14rows.t +t/18bc.t +t/21sth.t +t/23null.t +t/31txn.t +t/41ddtbl.t +t/42ddcol.t +t/43ddpk.t +t/44ddfk.t +t/51qi.t +t/75mil.t +t/DBD_TEST.pm
new file mode 100644 --- /dev/null +++ b/DBD/MANIFEST.SKIP @@ -0,0 +1,7 @@ +^Makefile$ +^Makefile\.ag$ +^Makefile\.old$ +^pm_to_blib$ +\.properties$ +^blib/ +\bCVS\b
new file mode 100644 --- /dev/null +++ b/DBD/Makefile.PL @@ -0,0 +1,9 @@ +use ExtUtils::MakeMaker; + +WriteMakefile +( + NAME => 'DBD::monetdb' +, VERSION_FROM => 'monetdb.pm' +, ABSTRACT_FROM => 'monetdb.pm' +, PREREQ_PM => { DBI => 1.45, 'MonetDB::CLI' => 0.01 } +);
new file mode 100644 --- /dev/null +++ b/DBD/Makefile.ag @@ -0,0 +1,15 @@ +# This Source Code Form is subject to the terms of the Mozilla Public +# License, v. 2.0. If a copy of the MPL was not distributed with this +# file, You can obtain one at http://mozilla.org/MPL/2.0/. +# +# Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + +MTSAFE + +SUBDIRS = monetdb + +headers_perl = { + HEADERS = pl pm + DIR = $(prefix)/$(PERL_LIBDIR)/DBD + SOURCES = monetdb.pm +}
new file mode 100644 --- /dev/null +++ b/DBD/README @@ -0,0 +1,97 @@ +NAME + + DBD::monetdb - MonetDB Driver for DBI + +SYNOPSIS + + use DBI(); + + my $dbh = DBI->connect('dbi:monetdb:'); + + my $sth = $dbh->prepare('SELECT * FROM env() env'); + $sth->execute; + $sth->dump_results; + +DESCRIPTION + + DBD::monetdb is a Pure Perl client interface for the MonetDB Database Server. + It requires MonetDB::CLI (and one of its implementations). + +PREREQUISITES + + DBI + MonetDB::CLI + + MonetDB (http://www.monetdb.org/) + +INSTALLATION + + To install this module type the following: + + perl Makefile.PL + make + make test + make install + + You need to use the correct make command. That may be nmake or dmake, + depending on which development environment you are using. + +TESTING + + The supplied tests will connect to the database using the DBI + environment variables, e.g.: + + set DBI_DSN=dbi:monetdb: + set DBI_DSN=dbi:monetdb:host=localhost + + Don't specify port and language (if possible). The server should + listen on the default ports for sql and mapi. + + If the server doesn't accept the default username/password, then + set the relevant environment variables, e.g.: + + set DBI_USER=test + set DBI_PASS=secret + + Make sure libMapi is in your library search path (depending on the + MonetDB::CLI implementations in use). + + The tests will create tables with the name (or prefix) 'perl_dbd_test' + in the current schema. + Check for the unlikly case that this will cause unwanted side effects! + + To run the tests, type + + make test + + If all tests pass, you'll see something like: + + t/01base.....ok + ... + t/75mil......ok + All tests successful. + Files=22, Tests=412, 10 wallclock secs ... + + It is possible to run individual test scripts, e.g.: + + perl -w -Mblib t/02cxn.t + + BTW: You can test the ODBC driver when setting the DSN appropriately, e.g.: + + set DBI_DSN=dbi:ODBC:driver=MonetDB ODBC Driver + +AUTHORS + + Martin Kersten <Martin.Kersten@cwi.nlE> implemented the initial Mapi + based version of the driver (monet.pm). + Arjan Scherpenisse <acscherp@science.uva.nlE> renamed this module to + monetdbPP.pm and derived the new MapiLib based version (monetdb.pm). + Current maintainer is Steffen Goeldner <sgoeldner@cpan.org>. + +COPYRIGHT AND LICENCE + + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at http://mozilla.org/MPL/2.0/. + + Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V.
new file mode 100644 --- /dev/null +++ b/DBD/monetdb.pm @@ -0,0 +1,880 @@ +package DBD::monetdb; + +use strict; +use DBI(); +use Encode(); +use MonetDB::CLI(); + +our $VERSION = '0.10'; +our $drh = undef; + +require DBD::monetdb::GetInfo; +require DBD::monetdb::TypeInfo; + + +sub driver { + return $drh if $drh; + + my ($class, $attr) = @_; + + $drh = DBI::_new_drh($class .'::dr', { + Name => 'monetdb', + Version => $VERSION, + Attribution => 'DBD::monetdb by Martin Kersten, Arjan Scherpenisse and Steffen Goeldner', + }); +} + + +sub CLONE { + undef $drh; +} + + + +package DBD::monetdb::dr; + +$DBD::monetdb::dr::imp_data_size = 0; + + +sub connect { + my ($drh, $dsn, $user, $password, $attr) = @_; + + my %dsn; + for ( split /;|:/, $dsn ||'') { + if ( my ( $k, $v ) = /(.*?)=(.*)/) { + $k = 'host' if $k eq 'hostname'; + $k = 'database' if $k eq 'dbname' || $k eq 'db'; + $dsn{$k} = $v; + next; + } + for my $k ( qw(host port database language) ) { + $dsn{$k} = $_, last unless defined $dsn{$k}; + } + } + my $lang = $dsn{language} || 'sql'; + my $host = $dsn{host} || 'localhost'; + my $port = $dsn{port} || 50000; + $user ||= 'monetdb'; + $password ||= 'monetdb'; + my $db = $dsn{database} || 'demo'; + + my $cxn = eval { MonetDB::CLI->connect($host, $port, $user, $password, $lang, $db) }; + return $drh->set_err(-1, $@) if $@; + + my ($outer, $dbh) = DBI::_new_dbh($drh, { Name => $dsn }); + + $dbh->STORE('Active', 1 ); + + $dbh->{monetdb_connection} = $cxn; + $dbh->{monetdb_language} = $lang; + + return $outer; +} + + +sub data_sources { + return ('dbi:monetdb:'); +} + + + +package DBD::monetdb::db; + +$DBD::monetdb::db::imp_data_size = 0; + + +sub ping { + my ($dbh) = @_; + + my $statement = $dbh->{monetdb_language} eq 'sql' ? 'select 7' : 'io.print(7);'; + my $rv = $dbh->selectrow_array($statement) || 0; + $dbh->set_err(undef, undef); + $rv == 7 ? 1 : 0; +} + + +sub quote { + my ($dbh, $value, $type) = @_; + + return $dbh->{monetdb_language} eq 'sql' ? 'NULL' : 'nil' + unless defined $value; + + $value = Encode::encode_utf8($value); + + for ($value) { + s/\\/\\\\/g; + s/\n/\\n/g; + s/"/\\"/g; + s/'/''/g; + } + + $type ||= DBI::SQL_VARCHAR(); + + my $prefix = $DBD::monetdb::TypeInfo::prefixes{$type} || ''; + my $suffix = $DBD::monetdb::TypeInfo::suffixes{$type} || ''; + + if ( $dbh->{monetdb_language} ne 'sql') { + $prefix = q(") if $prefix eq q('); + $suffix = q(") if $suffix eq q('); + } + return $prefix . $value . $suffix; +} + + +sub _count_param { + my $statement = shift; + my $num = 0; + + $statement =~ s{ + ' (?: \\. | [^\\']++ )*+ ' | + " (?: \\. | [^\\"]++ )*+ ' + }{}gx; + + return $statement =~ tr/?/?/; +} + + +sub prepare { + my ($dbh, $statement, $attr) = @_; + + my $cxn = $dbh->{monetdb_connection}; + my $hdl = eval { $cxn->new_handle }; + return $dbh->set_err(-1, $@) if $@; + + my ($outer, $sth) = DBI::_new_sth($dbh, { Statement => $statement }); + + $sth->STORE('NUM_OF_PARAMS', _count_param($statement)); + + $sth->{monetdb_hdl} = $hdl; + $sth->{monetdb_params} = []; + $sth->{monetdb_types} = []; + $sth->{monetdb_rows} = -1; + + return $outer; +} + + +sub commit { + my($dbh) = @_; + + if ($dbh->FETCH('AutoCommit')) { + warn 'Commit ineffective while AutoCommit is on' if $dbh->FETCH('Warn'); + return 0; + } + if ($dbh->{monetdb_language} eq 'sql') { + return $dbh->do('commit') + && $dbh->do('start transaction'); + } + else { + return $dbh->do('commit();'); + } +} + + +sub rollback { + my($dbh) = @_; + + if ($dbh->FETCH('AutoCommit')) { + warn 'Rollback ineffective while AutoCommit is on' if $dbh->FETCH('Warn'); + return 0; + } + if ($dbh->{monetdb_language} eq 'sql') { + return $dbh->do('rollback') + && $dbh->do('start transaction'); + } + else { + return $dbh->do('abort();'); + } +} + + +*get_info = \&DBD::monetdb::GetInfo::get_info; + + +sub monetdb_catalog_info { + my($dbh) = @_; + my $sql = <<'SQL'; +select cast( null as varchar( 128 ) ) as table_cat + , cast( null as varchar( 128 ) ) as table_schem + , cast( null as varchar( 128 ) ) as table_name + , cast( null as varchar( 254 ) ) as table_type + , cast( null as varchar( 254 ) ) as remarks + where 0 = 1 + order by table_cat +SQL + my $sth = $dbh->prepare($sql) or return; + $sth->execute or return; + return $sth; +} + + +sub monetdb_schema_info { + my($dbh) = @_; + my $sql = <<'SQL'; +select cast( null as varchar( 128 ) ) as table_cat + , "name" as table_schem + , cast( null as varchar( 128 ) ) as table_name + , cast( null as varchar( 254 ) ) as table_type + , cast( null as varchar( 254 ) ) as remarks + from sys."schemas" + order by table_schem +SQL + my $sth = $dbh->prepare($sql) or return; + $sth->execute or return; + return $sth; +} + + +my $ttp = { + 'TABLE' => 't."type" = 0 and t."system" = false and t."temporary" = 0 and s.name <> \'tmp\'' +,'GLOBAL TEMPORARY' => 't."type" = 0 and t."system" = false and t."temporary" = 0 and s.name = \'tmp\'' +,'SYSTEM TABLE' => 't."type" = 0 and t."system" = true and t."temporary" = 0' +,'LOCAL TEMPORARY' => 't."type" = 0 and t."system" = false and t."temporary" = 1' +,'VIEW' => 't."type" = 1 ' +}; + + +sub monetdb_tabletype_info { + my($dbh) = @_; + my $sql = <<"SQL"; +select distinct + cast( null as varchar( 128 ) ) as table_cat + , cast( null as varchar( 128 ) ) as table_schem + , cast( null as varchar( 128 ) ) as table_name + , case + when $ttp->{'TABLE' } then cast('TABLE' as varchar( 254 ) ) + when $ttp->{'SYSTEM TABLE' } then cast('SYSTEM TABLE' as varchar( 254 ) ) + when $ttp->{'LOCAL TEMPORARY' } then cast('LOCAL TEMPORARY' as varchar( 254 ) ) + when $ttp->{'GLOBAL TEMPORARY'} then cast('GLOBAL TEMPORARY' as varchar( 254 ) ) + when $ttp->{'VIEW' } then cast('VIEW' as varchar( 254 ) ) + else cast('INTERNAL TABLE TYPE' as varchar( 254 ) ) + end as table_type + , cast( null as varchar( 254 ) ) as remarks + from sys."tables" t, sys."schemas" s + where t."schema_id" = s."id" + order by table_type +SQL + my $sth = $dbh->prepare($sql) or return; + $sth->execute or return; + return $sth; +} + + +sub monetdb_table_info { + my($dbh, $c, $s, $t, $tt) = @_; + my $sql = <<"SQL"; +select cast( null as varchar( 128 ) ) as table_cat + , s."name" as table_schem + , t."name" as table_name + , case + when $ttp->{'TABLE' } then cast('TABLE' as varchar( 254 ) ) + when $ttp->{'SYSTEM TABLE' } then cast('SYSTEM TABLE' as varchar( 254 ) ) + when $ttp->{'LOCAL TEMPORARY' } then cast('LOCAL TEMPORARY' as varchar( 254 ) ) + when $ttp->{'GLOBAL TEMPORARY'} then cast('GLOBAL TEMPORARY' as varchar( 254 ) ) + when $ttp->{'VIEW' } then cast('VIEW' as varchar( 254 ) ) + else cast('INTERNAL TABLE TYPE' as varchar( 254 ) ) + end as table_type + , cast( null as varchar( 254 ) ) as remarks + from sys."schemas" s + , sys."tables" t + where t."schema_id" = s."id" +SQL + my @bv = (); + $sql .= qq( and s."name" like ?\n), push @bv, $s if $s; + $sql .= qq( and t."name" like ?\n), push @bv, $t if $t; + if ( @$tt ) { + $sql .= " and ( 1 = 0\n"; + for ( @$tt ) { + my $p = $ttp->{uc $_}; + $sql .= " or $p\n" if $p; + } + $sql .= " )\n"; + } + $sql .= " order by table_type, table_schem, table_name\n"; + my $sth = $dbh->prepare($sql) or return; + $sth->execute(@bv) or return; + + $dbh->set_err(0,"Catalog parameter c has to be an empty string, as MonetDB does not support multiple catalogs") if $c ne ""; + return $sth; +} + + +sub table_info { + my($dbh, $c, $s, $t, $tt) = @_; + + if ( defined $c && defined $s && defined $t ) { + if ( $c eq '%' && $s eq '' && $t eq '') { + return monetdb_catalog_info($dbh); + } + elsif ( $c eq '' && $s eq '%' && $t eq '') { + return monetdb_schema_info($dbh); + } + elsif ( $c eq '' && $s eq '' && $t eq '' && defined $tt && $tt eq '%') { + return monetdb_tabletype_info($dbh); + } + } + my @tt; + if ( defined $tt ) { + @tt = split /,/, $tt; + s/^\s*'?//, s/'?\s*$// for @tt; + } + return monetdb_table_info($dbh, $c, $s, $t, \@tt); +} + + +sub column_info { + my($dbh, $catalog, $schema, $table, $column) = @_; + # TODO: test $catalog for equality with empty string + my $sql = <<'SQL'; +select cast( null as varchar( 128 ) ) as table_cat + , s."name" as table_schem + , t."name" as table_name + , c."name" as column_name + , cast( 0 as smallint ) as data_type -- ... + , c."type" as type_name -- TODO + , cast( c."type_digits" as integer ) as column_size -- TODO + , cast( null as integer ) as buffer_length -- TODO + , cast( c."type_scale" as smallint ) as decimal_digits -- TODO + , cast( null as smallint ) as num_prec_radix -- TODO + , case c."null" + when false then cast( 0 as smallint ) -- SQL_NO_NULLS + when true then cast( 1 as smallint ) -- SQL_NULLABLE + end as nullable + , cast( null as varchar( 254 ) ) as remarks + , c."default" as column_def + , cast( 0 as smallint ) as sql_data_type -- ... + , cast( null as smallint ) as sql_datetime_sub -- ... + , cast( null as integer ) as char_octet_length -- TODO + , cast( c."number" + 1 as integer ) as ordinal_position + , case c."null" + when false then cast('NO' as varchar( 254 ) ) + when true then cast('YES' as varchar( 254 ) ) + end as is_nullable + from sys."schemas" s + , sys."tables" t + , sys."columns" c + where t."schema_id" = s."id" + and c."table_id" = t."id" +SQL + my @bv = (); + $sql .= qq( and s."name" like ?\n), push @bv, $schema if $schema; + $sql .= qq( and t."name" like ?\n), push @bv, $table if $table; + $sql .= qq( and c."name" like ?\n), push @bv, $column if $column; + $sql .= " order by table_cat, table_schem, table_name, ordinal_position\n"; + my $sth = $dbh->prepare($sql) or return; + $sth->execute(@bv) or return; + $dbh->set_err(0,"Catalog parameter catalog has to be an empty string, as MonetDB does not support multiple catalogs") if $catalog ne ""; + my $rows; + while ( my $row = $sth->fetch ) { + $row->[ 4] = $DBD::monetdb::TypeInfo::typeinfo{$row->[5]}->[ 1]; + $row->[13] = $DBD::monetdb::TypeInfo::typeinfo{$row->[5]}->[15]; + $row->[14] = $DBD::monetdb::TypeInfo::typeinfo{$row->[5]}->[16]; + push @$rows, [ @$row ]; + } + return DBI->connect('dbi:Sponge:','','', { RaiseError => 1 } )->prepare( + $sth->{Statement}, + { rows => $rows, NAME => $sth->{NAME}, TYPE => $sth->{TYPE} } + ); +} + + +sub primary_key_info { + my($dbh, $catalog, $schema, $table) = @_; + # TODO: test $catalog for equality with empty string + return $dbh->set_err(-1,'Undefined schema','HY009') unless defined $schema; + return $dbh->set_err(-1,'Undefined table' ,'HY009') unless defined $table; + my $sql = <<'SQL'; +select cast( null as varchar( 128 ) ) as table_cat + , s."name" as table_schem + , t."name" as table_name + , c."name" as column_name + , cast( c."nr" + 1 as smallint ) as key_seq + , k."name" as pk_name + from sys."schemas" s + , sys."tables" t + , sys."keys" k + , sys."objects" c + where t."schema_id" = s."id" + and k."table_id" = t."id" + and c."id" = k."id" + and s."name" = ? + and t."name" = ? + and k."type" = 0 + order by table_schem, table_name, key_seq +SQL + my $sth = $dbh->prepare($sql) or return; + $sth->execute($schema, $table) or return; + $dbh->set_err(0,"Catalog parameter catalog has to be an empty string, as MonetDB does not support multiple catalogs") if $catalog ne ""; + return $sth; +} + + +sub foreign_key_info { + my($dbh, $c1, $s1, $t1, $c2, $s2, $t2) = @_; + my $sql = <<'SQL'; +select cast( null as varchar( 128 ) ) as uk_table_cat + , uks."name" as uk_table_schem + , ukt."name" as uk_table_name + , ukc."name" as uk_column_name + , cast( null as varchar( 128 ) ) as fk_table_cat + , fks."name" as fk_table_schem + , fkt."name" as fk_table_name + , fkc."name" as fk_column_name + , cast( fkc."nr" + 1 as smallint ) as ordinal_position + , cast( 3 as smallint ) as update_rule -- SQL_NO_ACTION + , cast( 3 as smallint ) as delete_rule -- SQL_NO_ACTION + , fkk."name" as fk_name + , ukk."name" as uk_name + , cast( 7 as smallint ) as deferability -- SQL_NOT_DEFERRABLE + , case ukk."type" + when 0 then cast('PRIMARY' as varchar( 7 ) ) + when 1 then cast('UNIQUE' as varchar( 7 ) ) + else cast( ukk."type" as varchar( 7 ) ) + end as unique_or_primary + from sys."schemas" uks + , sys."tables" ukt + , sys."keys" ukk + , sys."objects" ukc + , sys."schemas" fks + , sys."tables" fkt + , sys."keys" fkk + , sys."objects" fkc + where ukt."schema_id" = uks."id" + and ukk."table_id" = ukt."id" + and ukc."id" = ukk."id" + and fkt."schema_id" = fks."id" + and fkk."table_id" = fkt."id" + and fkc."id" = fkk."id" +-- and ukk."type" IN ( 0, 1 ) +-- and fkk."type" = 2 +-- and fkk."rkey" > -1 + and fkk."rkey" = ukk."id" + and fkc."nr" = ukc."nr" +SQL + my @bv = (); + $sql .= qq( and uks."name" = ?\n), push @bv, $s1 if $s1; + $sql .= qq( and ukt."name" = ?\n), push @bv, $t1 if $t1; + $sql .= qq( and fks."name" = ?\n), push @bv, $s2 if $s2; + $sql .= qq( and fkt."name" = ?\n), push @bv, $t2 if $t2; + $sql .= qq( and ukk."type" = 0\n) if $t1 && !$t2; + $sql .= " order by uk_table_schem, uk_table_name, fk_table_schem, fk_table_name, ordinal_position\n"; + my $sth = $dbh->prepare($sql) or return; + $sth->execute(@bv) or return; + $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 ""; + return $sth; +} + + +*type_info_all = \&DBD::monetdb::TypeInfo::type_info_all; + + +sub tables { + my ($dbh, @args) = @_; + + # TODO: !! warn: 0 CLEARED by call to fetchall_arrayref method + return $dbh->SUPER::tables( @args ) if $dbh->{monetdb_language} eq 'sql'; + + return eval{ @{$dbh->selectcol_arrayref('ls();')} }; +} + + +sub disconnect { + my ($dbh) = @_; + + delete $dbh->{monetdb_connection}; + $dbh->STORE('Active', 0 ); + return 1; +} + + +sub FETCH { + my ($dbh, $key) = @_; + + return $dbh->{$key} if $key =~ /^monetdb_/; + return $dbh->SUPER::FETCH($key); +} + + +sub STORE { + my ($dbh, $key, $value) = @_; + + if ($key eq 'AutoCommit') { + return 1 if $dbh->{monetdb_language} ne 'sql'; + my $old_value = $dbh->{$key}; + if ($value && defined $old_value && !$old_value) { + $dbh->do('commit') + or return $dbh->set_err($dbh->err, $dbh->errstr); + } + elsif (!$value && (!defined $old_value || $old_value)) { + $dbh->do('start transaction') + or return $dbh->set_err($dbh->err, $dbh->errstr); + } + $dbh->{$key} = $value; + return 1; + } + elsif ($key =~ /^monetdb_/) { + $dbh->{$key} = $value; + return 1; + } + return $dbh->SUPER::STORE($key, $value); +} + + +sub DESTROY { + my ($dbh) = @_; + + $dbh->disconnect if $dbh->FETCH('Active'); +} + + + +package DBD::monetdb::st; + +$DBD::monetdb::st::imp_data_size = 0; + + +sub bind_param { + my ($sth, $index, $value, $attr) = @_; + + $sth->{monetdb_params}[$index-1] = $value; + $sth->{monetdb_types}[$index-1] = ref $attr ? $attr->{TYPE} : $attr; + return 1; +} + + +sub execute { + my($sth, @bind_values) = @_; + my $statement = $sth->{Statement}; + my $dbh = $sth->{Database}; + + $sth->STORE('Active', 0 ); # we don't need to call $sth->finish because + # mapi_query_handle() calls finish_handle() + + $sth->bind_param($_, $bind_values[$_-1]) or return for 1 .. @bind_values; + + my $params = $sth->{monetdb_params}; + my $num_of_params = $sth->FETCH('NUM_OF_PARAMS'); + return $sth->set_err(-1, @$params ." values bound when $num_of_params expected") + unless @$params == $num_of_params; + + for ( 1 .. $num_of_params ) { + my $quoted_param = $dbh->quote($params->[$_-1], $sth->{monetdb_types}[$_-1]); + $statement =~ s/\?/$quoted_param/; # TODO: '?' inside quotes/comments + } + $sth->trace_msg(" -- Statement: $statement\n", 5); + + my $hdl = $sth->{monetdb_hdl}; + eval{ $hdl->query($statement) }; + return $sth->set_err(-1, $@) if $@; + + my $rows = $hdl->rows_affected; + + if ( $dbh->{monetdb_language} eq 'sql' && $hdl->querytype != 1 ) { + $sth->{monetdb_rows} = $rows; + return $rows || '0E0'; + } + my ( @names, @types, @precisions, @nullables ); + my $field_count = $hdl->columncount; + for ( 0 .. $field_count-1 ) { + push @names , $hdl->name ($_); + push @types , $hdl->type ($_); + push @precisions, $hdl->length($_); + push @nullables , 2; # TODO + } + $sth->STORE('NUM_OF_FIELDS', $field_count) unless $sth->FETCH('NUM_OF_FIELDS'); + $sth->{NAME} = \@names; + $sth->{TYPE} = [ map { $DBD::monetdb::TypeInfo::typeinfo{$_}->[1] } @types ]; + $sth->{PRECISION} = \@precisions; # TODO + $sth->{SCALE} = []; + $sth->{NULLABLE} = \@nullables; + $sth->STORE('Active', 1 ); + + $sth->{monetdb_rows} = 0; + + return $rows || '0E0'; +} + + +sub fetch { + my ($sth) = @_; + + return $sth->set_err(-900,'Statement handle not marked as Active') + unless $sth->FETCH('Active'); + my $hdl = $sth->{monetdb_hdl}; + my $field_count = eval{ $hdl->fetch }; + unless ( $field_count ) { + $sth->STORE('Active', 0 ); + $sth->set_err(-1, $@) if $@; + return; + } + my @row = map $hdl->{currow}[$_], 0 .. $field_count-1; # encapsulation break but saves a microsecond per cell + map { s/\s+$// } @row if $sth->FETCH('ChopBlanks'); + + $sth->{monetdb_rows}++; + return $sth->_set_fbav(\@row); +} + +*fetchrow_arrayref = \&fetch; + + +sub rows { + my ($sth) = @_; + + return $sth->{monetdb_rows}; +} + + +sub finish { + my ($sth) = @_; + my $hdl = $sth->{monetdb_hdl}; + + eval{ $hdl->finish }; + return $sth->set_err(-1, $@) if $@; + + return $sth->SUPER::finish; # sets Active off +} + + +sub FETCH { + my ($sth, $key) = @_; + + if ( $key =~ /^monetdb_/) { + return $sth->{$key}; + } + elsif ( $key eq 'ParamValues') { + my $p = $sth->{monetdb_params}; + return { map { $_ => $p->[$_-1] } 1 .. $sth->FETCH('NUM_OF_PARAMS') }; + } + return $sth->SUPER::FETCH($key); +} + + +sub STORE { + my ($sth, $key, $value) = @_; + + if ($key =~ /^monetdb_/) { + $sth->{$key} = $value; + return 1; + } + return $sth->SUPER::STORE($key, $value); +} + + +sub DESTROY { + my ($sth) = @_; + + $sth->STORE('Active', 0 ); +} + + +1; + +__END__ + +=head1 NAME + +DBD::monetdb - MonetDB Driver for DBI + +=head1 SYNOPSIS + + use DBI(); + + my $dbh = DBI->connect('dbi:monetdb:'); + + my $sth = $dbh->prepare('SELECT * FROM env() env'); + $sth->execute; + $sth->dump_results; + +=head1 DESCRIPTION + +DBD::monetdb is a Pure Perl client interface for the MonetDB Database Server. +It requires MonetDB::CLI (and one of its implementations). + +=head2 Outline Usage + +From perl you activate the interface with the statement + + use DBI; + +After that you can connect to multiple MonetDB database servers +and send multiple queries to any of them via a simple object oriented +interface. Two types of objects are available: database handles and +statement handles. Perl returns a database handle to the connect +method like so: + + $dbh = DBI->connect("dbi:monetdb:host=$host", + $user, $password, { RaiseError => 1 } ); + +Once you have connected to a database, you can can execute SQL +statements with: + + my $sql = sprintf('INSERT INTO foo VALUES (%d, %s)', + $number, $dbh->quote('name')); + $dbh->do($sql); + +See L<DBI> for details on the quote and do methods. An alternative +approach is + + $dbh->do('INSERT INTO foo VALUES (?, ?)', undef, $number, $name); + +in which case the quote method is executed automatically. See also +the bind_param method in L<DBI>. + +If you want to retrieve results, you need to create a so-called +statement handle with: + + $sth = $dbh->prepare("SELECT id, name FROM $table"); + $sth->execute; + +This statement handle can be used for multiple things. First of all +you can retreive a row of data: + + my $row = $sth->fetch; + +If your table has columns ID and NAME, then $row will be array ref with +index 0 and 1. + +=head2 Example + + #!/usr/bin/perl + + use strict; + use DBI; + + # Connect to the database. + my $dbh = DBI->connect('dbi:monetdb:host=localhost', + 'joe', "joe's password", { RaiseError => 1 } ); + + # Drop table 'foo'. This may fail, if 'foo' doesn't exist. + # Thus we put an eval around it. + eval { $dbh->do('DROP TABLE foo') }; + print "Dropping foo failed: $@\n" if $@; + + # Create a new table 'foo'. This must not fail, thus we don't + # catch errors. + $dbh->do('CREATE TABLE foo (id INTEGER, name VARCHAR(20))'); + + # INSERT some data into 'foo'. We are using $dbh->quote() for + # quoting the name. + $dbh->do('INSERT INTO foo VALUES (1, ' . $dbh->quote('Tim') . ')'); + + # Same thing, but using placeholders + $dbh->do('INSERT INTO foo VALUES (?, ?)', undef, 2, 'Jochen'); + + # Now retrieve data from the table. + my $sth = $dbh->prepare('SELECT id, name FROM foo'); + $sth->execute; + while ( my $row = $sth->fetch ) { + print "Found a row: id = $row->[0], name = $row->[1]\n"; + } + + # Disconnect from the database. + $dbh->disconnect; + +=head1 METHODS + +=head2 Driver Handle Methods + +=over + +=item B<connect> + + use DBI(); + + $dsn = 'dbi:monetdb:'; + $dsn = "dbi:monetdb:host=$host"; + $dsn = "dbi:monetdb:host=$host;port=$port"; + $dsn = "dbi:monetdb:host=$host;database=$database"; + + $dbh = DBI->connect($dsn, $user, $password); + +=over + +=item host + +The default host to connect to is 'localhost', i.e. your workstation. + +=item port + +The port the MonetDB daemon listens to. Default for MonetDB is 50000. + +=item database + +The name of the database to connect to. + +=back + +=back + +=head2 Database Handle Methods + +The following methods are currently not supported: + + last_insert_id + +All MetaData methods are supported. However, column_info() currently doesn't +provide length (size, ...) related information. +The foreign_key_info() method returns a SQL/CLI like result set, +because it provides additional information about unique keys. + +=head2 Statement Handle Methods + +The following methods are currently not supported: + + bind_param_inout + more_results + blob_read + +=head1 ATTRIBUTES + +The following attributes are currently not supported: + + LongReadLen + LongTruncOk + +=head2 Database Handle Attributes + +The following attributes are currently not supported: + + RowCacheSize + +=head2 Statement Handle Attributes + +The following attributes are currently not (or not correctly) supported: + + PRECISION (MonetDB semantic != DBI semantic) + SCALE (empty) + NULLABLE (SQL_NULLABLE_UNKNOWN = 2) + CursorName + RowsInCache + +=head1 AUTHORS + +Martin Kersten E<lt>Martin.Kersten@cwi.nlE<gt> implemented the initial Mapi +based version of the driver (F<monet.pm>). +Arjan Scherpenisse E<lt>acscherp@science.uva.nlE<gt> renamed this module to +F<monetdbPP.pm> and derived the new MapiLib based version (F<monetdb.pm>). +Current maintainer is Steffen Goeldner E<lt>sgoeldner@cpan.orgE<gt>. + +=head1 COPYRIGHT AND LICENCE + +This Source Code Form is subject to the terms of the Mozilla Public +License, v. 2.0. If a copy of the MPL was not distributed with this +file, You can obtain one at http://mozilla.org/MPL/2.0/. + +Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + + +Contributor(s): Steffen Goeldner. + +=head1 SEE ALSO + +=head2 MonetDB + + Homepage : http://www.monetdb.org/ + +=head2 Perl modules + +L<DBI>, L<MonetDB::CLI> + +=cut
new file mode 100644 --- /dev/null +++ b/DBD/monetdb/GetInfo.pm @@ -0,0 +1,272 @@ +# This Source Code Form is subject to the terms of the Mozilla Public +# License, v. 2.0. If a copy of the MPL was not distributed with this +# file, You can obtain one at http://mozilla.org/MPL/2.0/. +# +# Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + +package DBD::monetdb::GetInfo; + +use strict; +use DBD::monetdb(); + +my $sql_driver = 'monetdb'; +my $sql_ver_fmt = '%02d.%02d.%04d'; # ODBC version string: ##.##.##### +my $sql_driver_ver = sprintf $sql_ver_fmt, split(/\./, $DBD::monetdb::VERSION), 0; + +my @Keywords = qw( +BOOLEAN +COLUMNS +FLOOR +IMPORT +REAL +); + +sub sql_keywords { + return join ',', @Keywords; +} + +sub sql_dbms_version { + my $dbh = shift; + return sprintf $sql_ver_fmt, 4, 6, 2; # TODO: mapi_... +} + +sub sql_data_source_name { + my $dbh = shift; + return "dbi:$sql_driver:" . $dbh->{Name}; +} + +sub sql_user_name { + my $dbh = shift; + return $dbh->{Username}; +} + +my %info = ( + 20 => 'Y', # SQL_ACCESSIBLE_PROCEDURES + 19 => 'N', # SQL_ACCESSIBLE_TABLES + 0 => 0, # SQL_ACTIVE_CONNECTIONS + 116 => 0, # SQL_ACTIVE_ENVIRONMENTS + 1 => 0, # SQL_ACTIVE_STATEMENTS + 169 => 127, # SQL_AGGREGATE_FUNCTIONS + 117 => 0, # SQL_ALTER_DOMAIN + 86 => 55656, # SQL_ALTER_TABLE + 10021 => 0, # SQL_ASYNC_MODE + 120 => 2, # SQL_BATCH_ROW_COUNT + 121 => 3, # SQL_BATCH_SUPPORT + 82 => 0, # SQL_BOOKMARK_PERSISTENCE + 114 => 0, # SQL_CATALOG_LOCATION + 10003 => 'N', # SQL_CATALOG_NAME + 41 => '', # SQL_CATALOG_NAME_SEPARATOR + 42 => '', # SQL_CATALOG_TERM + 92 => 0, # SQL_CATALOG_USAGE + 10004 => 'UTF-8', # SQL_COLLATING_SEQUENCE + 10004 => 'UTF-8', # SQL_COLLATION_SEQ + 87 => 'Y', # SQL_COLUMN_ALIAS + 22 => 0, # SQL_CONCAT_NULL_BEHAVIOR + 53 => 2097151, # SQL_CONVERT_BIGINT + 54 => 2097151, # SQL_CONVERT_BINARY + 55 => 2097151, # SQL_CONVERT_BIT + 56 => 2097151, # SQL_CONVERT_CHAR + 57 => 2097151, # SQL_CONVERT_DATE + 58 => 2097151, # SQL_CONVERT_DECIMAL + 59 => 2097151, # SQL_CONVERT_DOUBLE + 60 => 2097151, # SQL_CONVERT_FLOAT + 48 => 3, # SQL_CONVERT_FUNCTIONS +# 173 => undef, # SQL_CONVERT_GUID + 61 => 2097151, # SQL_CONVERT_INTEGER + 123 => 2097151, # SQL_CONVERT_INTERVAL_DAY_TIME + 124 => 2097151, # SQL_CONVERT_INTERVAL_YEAR_MONTH + 71 => 2097151, # SQL_CONVERT_LONGVARBINARY + 62 => 2097151, # SQL_CONVERT_LONGVARCHAR + 63 => 2097151, # SQL_CONVERT_NUMERIC + 64 => 2097151, # SQL_CONVERT_REAL + 65 => 2097151, # SQL_CONVERT_SMALLINT + 66 => 2097151, # SQL_CONVERT_TIME + 67 => 2097151, # SQL_CONVERT_TIMESTAMP + 68 => 2097151, # SQL_CONVERT_TINYINT + 69 => 2097151, # SQL_CONVERT_VARBINARY + 70 => 2097151, # SQL_CONVERT_VARCHAR +# 122 => undef, # SQL_CONVERT_WCHAR +# 125 => undef, # SQL_CONVERT_WLONGVARCHAR +# 126 => undef, # SQL_CONVERT_WVARCHAR + 74 => 2, # SQL_CORRELATION_NAME + 127 => 0, # SQL_CREATE_ASSERTION + 128 => 0, # SQL_CREATE_CHARACTER_SET + 129 => 0, # SQL_CREATE_COLLATION + 130 => 0, # SQL_CREATE_DOMAIN + 131 => 3, # SQL_CREATE_SCHEMA + 132 => 13851, # SQL_CREATE_TABLE + 133 => 0, # SQL_CREATE_TRANSLATION + 134 => 3, # SQL_CREATE_VIEW + 23 => 0, # SQL_CURSOR_COMMIT_BEHAVIOR + 24 => 0, # SQL_CURSOR_ROLLBACK_BEHAVIOR + 10001 => 1, # SQL_CURSOR_SENSITIVITY + 2 => \&sql_data_source_name, # SQL_DATA_SOURCE_NAME + 25 => 'N', # SQL_DATA_SOURCE_READ_ONLY + 119 => 0, # SQL_DATETIME_LITERALS + 17 => 'MonetDB', # SQL_DBMS_NAME + 18 => \&sql_dbms_version, # SQL_DBMS_VERSION + 170 => 0, # SQL_DDL_INDEX + 26 => 2, # SQL_DEFAULT_TRANSACTION_ISOLATION + 26 => 2, # SQL_DEFAULT_TXN_ISOLATION + 10002 => 'N', # SQL_DESCRIBE_PARAMETER +#- 171 => '03.52.6019.0000', # SQL_DM_VER +#- 3 => 28510912, # SQL_DRIVER_HDBC +# 135 => undef, # SQL_DRIVER_HDESC +#- 4 => 28510880, # SQL_DRIVER_HENV +# 76 => undef, # SQL_DRIVER_HLIB +# 5 => undef, # SQL_DRIVER_HSTMT + 6 => $INC{'DBD/monetdb.pm'}, # SQL_DRIVER_NAME +#- 77 => '03.52', # SQL_DRIVER_ODBC_VER + 7 => $sql_driver_ver, # SQL_DRIVER_VER + 136 => 0, # SQL_DROP_ASSERTION + 137 => 0, # SQL_DROP_CHARACTER_SET + 138 => 0, # SQL_DROP_COLLATION + 139 => 0, # SQL_DROP_DOMAIN + 140 => 0, # SQL_DROP_SCHEMA + 141 => 0, # SQL_DROP_TABLE + 142 => 0, # SQL_DROP_TRANSLATION + 143 => 0, # SQL_DROP_VIEW + 144 => 0, # SQL_DYNAMIC_CURSOR_ATTRIBUTES1 + 145 => 0, # SQL_DYNAMIC_CURSOR_ATTRIBUTES2 + 27 => 'Y', # SQL_EXPRESSIONS_IN_ORDERBY + 8 => 1, # SQL_FETCH_DIRECTION + 84 => 0, # SQL_FILE_USAGE + 146 => 0, # SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES1 + 147 => 0, # SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES2 + 81 => 15, # SQL_GETDATA_EXTENSIONS + 88 => 3, # SQL_GROUP_BY + 28 => 2, # SQL_IDENTIFIER_CASE + 29 => '"', # SQL_IDENTIFIER_QUOTE_CHAR +# 148 => undef, # SQL_INDEX_KEYWORDS + 149 => 0, # SQL_INFO_SCHEMA_VIEWS + 172 => 0, # SQL_INSERT_STATEMENT + 73 => 'N', # SQL_INTEGRITY + 150 => 0, # SQL_KEYSET_CURSOR_ATTRIBUTES1 + 151 => 0, # SQL_KEYSET_CURSOR_ATTRIBUTES2 + 89 => \&sql_keywords, # SQL_KEYWORDS + 113 => 'Y', # SQL_LIKE_ESCAPE_CLAUSE + 78 => 0, # SQL_LOCK_TYPES + 34 => 255, # SQL_MAXIMUM_CATALOG_NAME_LENGTH + 97 => 0, # SQL_MAXIMUM_COLUMNS_IN_GROUP_BY + 98 => 0, # SQL_MAXIMUM_COLUMNS_IN_INDEX + 99 => 0, # SQL_MAXIMUM_COLUMNS_IN_ORDER_BY + 100 => 0, # SQL_MAXIMUM_COLUMNS_IN_SELECT + 101 => 0, # SQL_MAXIMUM_COLUMNS_IN_TABLE + 30 => 255, # SQL_MAXIMUM_COLUMN_NAME_LENGTH + 1 => 0, # SQL_MAXIMUM_CONCURRENT_ACTIVITIES + 31 => 0, # SQL_MAXIMUM_CURSOR_NAME_LENGTH + 0 => 0, # SQL_MAXIMUM_DRIVER_CONNECTIONS + 10005 => 0, # SQL_MAXIMUM_IDENTIFIER_LENGTH + 102 => 0, # SQL_MAXIMUM_INDEX_SIZE + 104 => 0, # SQL_MAXIMUM_ROW_SIZE + 32 => 255, # SQL_MAXIMUM_SCHEMA_NAME_LENGTH + 105 => 0, # SQL_MAXIMUM_STATEMENT_LENGTH +# 20000 => undef, # SQL_MAXIMUM_STMT_OCTETS +# 20001 => undef, # SQL_MAXIMUM_STMT_OCTETS_DATA +# 20002 => undef, # SQL_MAXIMUM_STMT_OCTETS_SCHEMA + 106 => 0, # SQL_MAXIMUM_TABLES_IN_SELECT + 35 => 255, # SQL_MAXIMUM_TABLE_NAME_LENGTH + 107 => 0, # SQL_MAXIMUM_USER_NAME_LENGTH + 10022 => 0, # SQL_MAX_ASYNC_CONCURRENT_STATEMENTS + 112 => 0, # SQL_MAX_BINARY_LITERAL_LEN + 34 => 255, # SQL_MAX_CATALOG_NAME_LEN + 108 => 1048576, # SQL_MAX_CHAR_LITERAL_LEN + 97 => 0, # SQL_MAX_COLUMNS_IN_GROUP_BY + 98 => 0, # SQL_MAX_COLUMNS_IN_INDEX + 99 => 0, # SQL_MAX_COLUMNS_IN_ORDER_BY + 100 => 0, # SQL_MAX_COLUMNS_IN_SELECT + 101 => 0, # SQL_MAX_COLUMNS_IN_TABLE + 30 => 255, # SQL_MAX_COLUMN_NAME_LEN + 1 => 0, # SQL_MAX_CONCURRENT_ACTIVITIES + 31 => 0, # SQL_MAX_CURSOR_NAME_LEN + 0 => 0, # SQL_MAX_DRIVER_CONNECTIONS + 10005 => 0, # SQL_MAX_IDENTIFIER_LEN + 102 => 0, # SQL_MAX_INDEX_SIZE + 32 => 255, # SQL_MAX_OWNER_NAME_LEN + 33 => 0, # SQL_MAX_PROCEDURE_NAME_LEN + 34 => 255, # SQL_MAX_QUALIFIER_NAME_LEN + 104 => 0, # SQL_MAX_ROW_SIZE + 103 => 'N', # SQL_MAX_ROW_SIZE_INCLUDES_LONG + 32 => 255, # SQL_MAX_SCHEMA_NAME_LEN + 105 => 0, # SQL_MAX_STATEMENT_LEN + 106 => 0, # SQL_MAX_TABLES_IN_SELECT + 35 => 255, # SQL_MAX_TABLE_NAME_LEN + 107 => 0, # SQL_MAX_USER_NAME_LEN + 37 => 'Y', # SQL_MULTIPLE_ACTIVE_TXN + 36 => 'N', # SQL_MULT_RESULT_SETS + 111 => 'Y', # SQL_NEED_LONG_DATA_LEN + 75 => 1, # SQL_NON_NULLABLE_COLUMNS + 85 => 1, # SQL_NULL_COLLATION + 49 => 16777215, # SQL_NUMERIC_FUNCTIONS + 9 => 1, # SQL_ODBC_API_CONFORMANCE + 152 => 1, # SQL_ODBC_INTERFACE_CONFORMANCE + 12 => 1, # SQL_ODBC_SAG_CLI_CONFORMANCE + 15 => 1, # SQL_ODBC_SQL_CONFORMANCE + 73 => 'N', # SQL_ODBC_SQL_OPT_IEF +#- 10 => '03.52.0000', # SQL_ODBC_VER + 115 => 0, # SQL_OJ_CAPABILITIES + 90 => 'N', # SQL_ORDER_BY_COLUMNS_IN_SELECT + 38 => 'Y', # SQL_OUTER_JOINS + 115 => 0, # SQL_OUTER_JOIN_CAPABILITIES + 39 => '', # SQL_OWNER_TERM + 91 => 0, # SQL_OWNER_USAGE + 153 => 0, # SQL_PARAM_ARRAY_ROW_COUNTS + 154 => 0, # SQL_PARAM_ARRAY_SELECTS + 80 => 4, # SQL_POSITIONED_STATEMENTS + 79 => 0, # SQL_POS_OPERATIONS + 21 => 'N', # SQL_PROCEDURES + 40 => '', # SQL_PROCEDURE_TERM + 114 => 0, # SQL_QUALIFIER_LOCATION + 41 => '', # SQL_QUALIFIER_NAME_SEPARATOR + 42 => '', # SQL_QUALIFIER_TERM + 92 => 0, # SQL_QUALIFIER_USAGE + 93 => 3, # SQL_QUOTED_IDENTIFIER_CASE + 11 => 'N', # SQL_ROW_UPDATES + 39 => '', # SQL_SCHEMA_TERM + 91 => 0, # SQL_SCHEMA_USAGE + 43 => 1, # SQL_SCROLL_CONCURRENCY + 44 => 16, # SQL_SCROLL_OPTIONS + 14 => '', # SQL_SEARCH_PATTERN_ESCAPE + 13 => 'MonetDB', # SQL_SERVER_NAME + 94 => '`!#$;:\'<>', # SQL_SPECIAL_CHARACTERS +# 155 => undef, # SQL_SQL92_DATETIME_FUNCTIONS +# 156 => undef, # SQL_SQL92_FOREIGN_KEY_DELETE_RULE +# 157 => undef, # SQL_SQL92_FOREIGN_KEY_UPDATE_RULE +# 158 => undef, # SQL_SQL92_GRANT +# 159 => undef, # SQL_SQL92_NUMERIC_VALUE_FUNCTIONS +# 160 => undef, # SQL_SQL92_PREDICATES +# 161 => undef, # SQL_SQL92_RELATIONAL_JOIN_OPERATORS +# 162 => undef, # SQL_SQL92_REVOKE +# 163 => undef, # SQL_SQL92_ROW_VALUE_CONSTRUCTOR +# 164 => undef, # SQL_SQL92_STRING_FUNCTIONS +# 165 => undef, # SQL_SQL92_VALUE_EXPRESSIONS + 118 => 8, # SQL_SQL_CONFORMANCE +# 166 => undef, # SQL_STANDARD_CLI_CONFORMANCE + 167 => 583, # SQL_STATIC_CURSOR_ATTRIBUTES1 + 168 => 4096, # SQL_STATIC_CURSOR_ATTRIBUTES2 + 83 => 0, # SQL_STATIC_SENSITIVITY + 50 => 458751, # SQL_STRING_FUNCTIONS + 95 => 23, # SQL_SUBQUERIES + 51 => 7, # SQL_SYSTEM_FUNCTIONS + 45 => '', # SQL_TABLE_TERM + 109 => 0, # SQL_TIMEDATE_ADD_INTERVALS + 110 => 0, # SQL_TIMEDATE_DIFF_INTERVALS + 52 => 131071, # SQL_TIMEDATE_FUNCTIONS + 46 => 2, # SQL_TRANSACTION_CAPABLE + 72 => 4, # SQL_TRANSACTION_ISOLATION_OPTION + 46 => 2, # SQL_TXN_CAPABLE + 72 => 4, # SQL_TXN_ISOLATION_OPTION + 96 => 1, # SQL_UNION + 96 => 1, # SQL_UNION_STATEMENT + 47 => \&sql_user_name, # SQL_USER_NAME + 10000 => '', # SQL_XOPEN_CLI_YEAR +); + +sub get_info { + my ($dbh, $info_type) = @_; + my $value = $info{int($info_type)}; + $value = $value->($dbh) if ref $value eq 'CODE'; + return $value; +} + +1;
new file mode 100644 --- /dev/null +++ b/DBD/monetdb/Makefile.ag @@ -0,0 +1,13 @@ +# This Source Code Form is subject to the terms of the Mozilla Public +# License, v. 2.0. If a copy of the MPL was not distributed with this +# file, You can obtain one at http://mozilla.org/MPL/2.0/. +# +# Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + +MTSAFE + +headers_perl = { + HEADERS = pm + DIR = $(prefix)/$(PERL_LIBDIR)/DBD/monetdb + SOURCES = GetInfo.pm TypeInfo.pm +}
new file mode 100644 --- /dev/null +++ b/DBD/monetdb/TypeInfo.pm @@ -0,0 +1,101 @@ +# This Source Code Form is subject to the terms of the Mozilla Public +# License, v. 2.0. If a copy of the MPL was not distributed with this +# file, You can obtain one at http://mozilla.org/MPL/2.0/. +# +# Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + +package DBD::monetdb::TypeInfo; + +use DBI qw(:sql_types); + +my %index = +( + TYPE_NAME => 0 +, DATA_TYPE => 1 +, COLUMN_SIZE => 2 +, LITERAL_PREFIX => 3 +, LITERAL_SUFFIX => 4 +, CREATE_PARAMS => 5 +, NULLABLE => 6 +, CASE_SENSITIVE => 7 +, SEARCHABLE => 8 +, UNSIGNED_ATTRIBUTE => 9 +, FIXED_PREC_SCALE => 10 +, AUTO_UNIQUE_VALUE => 11 +, LOCAL_TYPE_NAME => 12 +, MINIMUM_SCALE => 13 +, MAXIMUM_SCALE => 14 +, SQL_DATA_TYPE => 15 +, SQL_DATETIME_SUB => 16 +, NUM_PREC_RADIX => 17 +, INTERVAL_PRECISION => 18 +); + +my @data = +( +# NAME TYPE SIZE PREFIX SUFFIX PARAMS N C S U F A NAME MIN MAX TYPE SUB RADIX IV_P + ['char' , SQL_CHAR , 1000000, "'" , "'" ,'length' , 1, 1, 3, undef, 0, 0, undef, undef, undef, SQL_CHAR , undef, undef, undef ] +, ['character' , SQL_CHAR , 1000000, "'" , "'" ,'length' , 1, 1, 3, undef, 0, 0, undef, undef, undef, SQL_CHAR , undef, undef, undef ] +, ['decimal' , SQL_DECIMAL , 19, undef, undef,'precision,scale', 1, 0, 2, 0, 0, 0, undef, 0, 19, SQL_DECIMAL , undef, 10, undef ] +, ['dec' , SQL_DECIMAL , 19, undef, undef,'precision,scale', 1, 0, 2, 0, 0, 0, undef, 0, 19, SQL_DECIMAL , undef, 10, undef ] +, ['numeric' , SQL_DECIMAL , 19, undef, undef,'precision,scale', 1, 0, 2, 0, 0, 0, undef, 0, 19, SQL_DECIMAL , undef, 10, undef ] +, ['int' , SQL_INTEGER , 9, undef, undef, undef , 1, 0, 2, 0, 0, 0, undef, 0, 0, SQL_INTEGER , undef, 10, undef ] +, ['integer' , SQL_INTEGER , 9, undef, undef, undef , 1, 0, 2, 0, 0, 0, undef, 0, 0, SQL_INTEGER , undef, 10, undef ] +, ['mediumint' , SQL_INTEGER , 9, undef, undef, undef , 1, 0, 2, 0, 0, 0, undef, 0, 0, SQL_INTEGER , undef, 10, undef ] +, ['smallint' , SQL_SMALLINT , 4, undef, undef, undef , 1, 0, 2, 0, 0, 0, undef, 0, 0, SQL_SMALLINT, undef, 10, undef ] +, ['tinyint' , SQL_SMALLINT , 4, undef, undef, undef , 1, 0, 2, 0, 0, 0, undef, 0, 0, SQL_SMALLINT, undef, 10, undef ] +, ['float' , SQL_FLOAT , 24, undef, undef,'precision,scale', 1, 0, 2, 0, 0, 0, undef, 0, 0, SQL_FLOAT , undef, 2, undef ] +, ['real' , SQL_REAL , 24, undef, undef, undef , 1, 0, 2, 0, 0, 0, undef, 0, 0, SQL_REAL , undef, 2, undef ] +, ['double' , SQL_DOUBLE , 53, undef, undef, undef , 1, 0, 2, 0, 0, 0, undef, 0, 0, SQL_DOUBLE , undef, 2, undef ] +, ['double precision' , SQL_DOUBLE , 53, undef, undef, undef , 1, 0, 2, 0, 0, 0, undef, 0, 0, SQL_DOUBLE , undef, 2, undef ] +, ['varchar' , SQL_VARCHAR , 1000000, "'" , "'" ,'length' , 1, 1, 3, undef, 0, undef, undef, undef, undef, SQL_VARCHAR , undef, undef, undef ] +, ['character varying' , SQL_VARCHAR , 1000000, "'" , "'" ,'length' , 1, 1, 3, undef, 0, undef, undef, undef, undef, SQL_VARCHAR , undef, undef, undef ] +, ['char varying' , SQL_VARCHAR , 1000000, "'" , "'" ,'length' , 1, 1, 3, undef, 0, undef, undef, undef, undef, SQL_VARCHAR , undef, undef, undef ] +, ['boolean' , SQL_BOOLEAN , 1, undef, undef, undef , 1, 0, 2, 0, 1, 0, undef, undef, undef, SQL_BOOLEAN , undef, undef, undef ] +, ['bool' , SQL_BOOLEAN , 1, undef, undef, undef , 1, 0, 2, 0, 1, 0, undef, undef, undef, SQL_BOOLEAN , undef, undef, undef ] +, ['bigint' , 25 , 19, undef, undef, undef , 1, 0, 2, 0, 0, 0, undef, 0, 0, 25 , undef, 10, undef ] +, ['blob' , SQL_BLOB , 1000000, "'" , "'" ,'length' , 1, 1, 3, undef, 0, undef, undef, undef, undef, SQL_BLOB , undef, undef, undef ] +, ['binary large object' , SQL_BLOB , 1000000, "'" , "'" ,'length' , 1, 1, 3, undef, 0, undef, undef, undef, undef, SQL_BLOB , undef, undef, undef ] +, ['clob' , SQL_CLOB , 1000000, "'" , "'" ,'length' , 1, 1, 3, undef, 0, undef, undef, undef, undef, SQL_CLOB , undef, undef, undef ] +, ['character large object' , SQL_CLOB , 1000000, "'" , "'" ,'length' , 1, 1, 3, undef, 0, undef, undef, undef, undef, SQL_CLOB , undef, undef, undef ] +, ['char large object' , SQL_CLOB , 1000000, "'" , "'" ,'length' , 1, 1, 3, undef, 0, undef, undef, undef, undef, SQL_CLOB , undef, undef, undef ] +, ['string' , SQL_CLOB , 1000000, "'" , "'" ,'length' , 1, 1, 3, undef, 0, undef, undef, undef, undef, SQL_CLOB , undef, undef, undef ] +, ['text' , SQL_CLOB , 1000000, "'" , "'" ,'length' , 1, 1, 3, undef, 0, undef, undef, undef, undef, SQL_CLOB , undef, undef, undef ] +, ['tinytext' , SQL_CLOB , 1000000, "'" , "'" ,'length' , 1, 1, 3, undef, 0, undef, undef, undef, undef, SQL_CLOB , undef, undef, undef ] +, ['date' , SQL_TYPE_DATE , 10, "date '", "'" , undef , 1, 0, 2, undef, 0, undef, undef, undef, undef, SQL_DATE , 1, undef, undef ] +, ['time' , SQL_TYPE_TIME , 12, "time '", "'" ,'precision' , 1, 0, 2, undef, 0, undef, undef, undef, undef, SQL_DATE , 2, undef, undef ] +, ['timestamp' , SQL_TYPE_TIMESTAMP , 23, "timestamp '", "'" ,'precision' , 1, 0, 2, undef, 0, undef, undef, undef, undef, SQL_DATE , 3, undef, undef ] +, ['timetz' , SQL_TYPE_TIME_WITH_TIMEZONE , 18, "time '", "'" ,'precision' , 1, 0, 2, undef, 0, undef, undef, undef, undef, SQL_DATE , 4, undef, undef ] +, ['time with time zone' , SQL_TYPE_TIME_WITH_TIMEZONE , 18, "time '", "'" ,'precision' , 1, 0, 2, undef, 0, undef, undef, undef, undef, SQL_DATE , 4, undef, undef ] +, ['timestamptz' , SQL_TYPE_TIMESTAMP_WITH_TIMEZONE, 29, "timestamp '", "'" ,'precision' , 1, 0, 2, undef, 0, undef, undef, undef, undef, SQL_DATE , 5, undef, undef ] +, ['timestamp with time zone' , SQL_TYPE_TIMESTAMP_WITH_TIMEZONE, 29, "timestamp '", "'" ,'precision' , 1, 0, 2, undef, 0, undef, undef, undef, undef, SQL_DATE , 5, undef, undef ] +, ['interval year' , SQL_INTERVAL_YEAR , 9, "interval '", "' year" ,'precision' , 1, 0, 2, undef, 0, undef, undef, 0, 0, SQL_TIME , 1, undef, 9 ] +, ['interval month' , SQL_INTERVAL_MONTH , 10, "interval '", "' month" ,'precision' , 1, 0, 2, undef, 0, undef, undef, 0, 0, SQL_TIME , 2, undef, 10 ] +, ['month_interval' , SQL_INTERVAL_MONTH , 10, "interval '", "' month" ,'precision' , 1, 0, 2, undef, 0, undef, undef, 0, 0, SQL_TIME , 2, undef, 10 ] +, ['interval day' , SQL_INTERVAL_DAY , 5, "interval '", "' day" ,'precision' , 1, 0, 2, undef, 0, undef, undef, 0, 0, SQL_TIME , 3, undef, 5 ] +, ['interval hour' , SQL_INTERVAL_HOUR , 6, "interval '", "' hour" ,'precision' , 1, 0, 2, undef, 0, undef, undef, 0, 0, SQL_TIME , 4, undef, 6 ] +, ['interval minute' , SQL_INTERVAL_MINUTE , 8, "interval '", "' minute" ,'precision' , 1, 0, 2, undef, 0, undef, undef, 0, 0, SQL_TIME , 5, undef, 8 ] +, ['interval second' , SQL_INTERVAL_SECOND , 10, "interval '", "' second" ,'precision' , 1, 0, 2, undef, 0, undef, undef, 0, 0, SQL_TIME , 6, undef, 10 ] +, ['sec_interval' , SQL_INTERVAL_SECOND , 10, "interval '", "' second" ,'precision' , 1, 0, 2, undef, 0, undef, undef, 0, 0, SQL_TIME , 6, undef, 10 ] +, ['interval year to month' , SQL_INTERVAL_YEAR_TO_MONTH , 12, "interval '", "' year to month" , undef , 1, 0, 2, undef, 0, undef, undef, 0, 0, SQL_TIME , 7, undef, 9 ] +, ['interval day to hour' , SQL_INTERVAL_DAY_TO_HOUR , 8, "interval '", "' day to hour" , undef , 1, 0, 2, undef, 0, undef, undef, 0, 0, SQL_TIME , 8, undef, 5 ] +, ['interval day to minute' , SQL_INTERVAL_DAY_TO_MINUTE , 11, "interval '", "' day to minute" , undef , 1, 0, 2, undef, 0, undef, undef, 0, 0, SQL_TIME , 9, undef, 5 ] +, ['interval day to second' , SQL_INTERVAL_DAY_TO_SECOND , 14, "interval '", "' day to second" ,'precision' , 1, 0, 2, undef, 0, undef, undef, 0, 0, SQL_TIME , 10, undef, 5 ] +, ['interval hour to minute' , SQL_INTERVAL_HOUR_TO_MINUTE , 9, "interval '", "' hour to minute" , undef , 1, 0, 2, undef, 0, undef, undef, 0, 0, SQL_TIME , 11, undef, 6 ] +, ['interval hour to second' , SQL_INTERVAL_HOUR_TO_SECOND , 12, "interval '", "' hour to second" ,'precision' , 1, 0, 2, undef, 0, undef, undef, 0, 0, SQL_TIME , 12, undef, 6 ] +, ['interval minute to second', SQL_INTERVAL_MINUTE_TO_SECOND , 13, "interval '", "' minute to second",'precision' , 1, 0, 2, undef, 0, undef, undef, 0, 0, SQL_TIME , 13, undef, 10 ] +); + +sub type_info_all { [ \%index, @data ] } + +%typeinfo = (); +%prefixes = (); +%suffixes = (); + +for ( @data ) { + $typeinfo{$_->[0]} = $_; + $prefixes{$_->[1]} = $_->[3]; + $suffixes{$_->[1]} = $_->[4]; +} + +1;
new file mode 100644 --- /dev/null +++ b/DBD/t/01base.t @@ -0,0 +1,21 @@ +# This Source Code Form is subject to the terms of the Mozilla Public +# License, v. 2.0. If a copy of the MPL was not distributed with this +# file, You can obtain one at http://mozilla.org/MPL/2.0/. +# +# Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + +use Test::More tests => 5; + +require DBI; +pass 'DBI required'; + +import DBI; +pass 'DBI imported'; + +$switch = DBI->internal; +is ref $switch,'DBI::dr','switch'; + +$drh = DBI->install_driver('monetdb'); +is ref $drh,'DBI::dr','drh'; + +ok $drh->{Version},'Version: ' . $drh->{Version};
new file mode 100644 --- /dev/null +++ b/DBD/t/02ads.t @@ -0,0 +1,25 @@ +#!perl -I./t + +# This Source Code Form is subject to the terms of the Mozilla Public +# License, v. 2.0. If a copy of the MPL was not distributed with this +# file, You can obtain one at http://mozilla.org/MPL/2.0/. +# +# Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + +$| = 1; + +use strict; +use warnings; +use DBI(); + +use Test::More tests => 2; + + +pass('Data sources tests'); + +my @ds = DBI->data_sources('monetdb'); + +print "\n# Data sources:\n"; +print '# ', $_, "\n" for @ds; + +pass('Data sources tested');
new file mode 100644 --- /dev/null +++ b/DBD/t/02cxn.t @@ -0,0 +1,43 @@ +#!perl -I./t + +# This Source Code Form is subject to the terms of the Mozilla Public +# License, v. 2.0. If a copy of the MPL was not distributed with this +# file, You can obtain one at http://mozilla.org/MPL/2.0/. +# +# Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + +$| = 1; + +use strict; +use warnings; +use DBI(); + +use Test::More; + +if (defined $ENV{DBI_DSN}) { + plan tests => 8; +} else { + plan skip_all => 'Cannot test without DB info'; +} + +pass('Connection tests'); + +my $dbh = DBI->connect or die "Connect failed: $DBI::errstr\n"; +pass('Database connection created'); + +SKIP: { + skip('DBD::monetdb specific test', 1 ) if $dbh->{Driver}{Name} ne 'monetdb'; + + my $Cxn = $dbh->{monetdb_connection}; + + ok( $Cxn,"Connection object: $Cxn"); +} +ok( $dbh->ping,'Ping'); + +ok( $dbh->{Active},'Active'); + +ok( $dbh->disconnect,'Disconnect'); + +ok(!$dbh->ping,'Ping'); + +ok(!$dbh->{Active},'Active');
new file mode 100644 --- /dev/null +++ b/DBD/t/05gi.t @@ -0,0 +1,84 @@ +#!perl -I./t + +# This Source Code Form is subject to the terms of the Mozilla Public +# License, v. 2.0. If a copy of the MPL was not distributed with this +# file, You can obtain one at http://mozilla.org/MPL/2.0/. +# +# Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + +$| = 1; + +use strict; +use warnings; +use DBI(); + +use Test::More; + +if (defined $ENV{DBI_DSN}) { + plan tests => 9; +} else { + plan skip_all => 'Cannot test without DB info'; +} + +pass('Get info tests'); + +my $dbh = DBI->connect or die "Connect failed: $DBI::errstr\n"; +pass('Database connection created'); + +eval { $dbh->get_info }; +ok( $@,"Call to get_info with 0 arguments, error expected: $@"); + +my $get_info = { + SQL_DBMS_NAME => 17 +, SQL_DBMS_VER => 18 +, SQL_IDENTIFIER_QUOTE_CHAR => 29 +, SQL_CATALOG_NAME_SEPARATOR => 41 +, SQL_CATALOG_LOCATION => 114 +}; + +for ( sort keys %$get_info ) { + my $info = $dbh->get_info( $get_info->{$_} ); + ok( defined $info,"get_info( $get_info->{$_} ) ($_): $info"); +} + +eval { + + print "\nList of all defined GetInfo types:\n"; + + require DBI::Const::GetInfoType; + require DBI::Const::GetInfoReturn; + + for ( sort keys %DBI::Const::GetInfoType::GetInfoType ) { + my $Nr = $DBI::Const::GetInfoType::GetInfoType{$_}; + my $Val = $dbh->get_info( $Nr ); + next unless defined $Val; + my $Str = DBI::Const::GetInfoReturn::Format( $_, $Val ); + my $Exp = join ' | ', DBI::Const::GetInfoReturn::Explain( $_, $Val ); + printf " %6d %-35s %-13s %s\n", $Nr, $_, $Str, $Exp; + } +}; +ok( $dbh->disconnect,'Disconnect'); + +__END__ + + SQL_CATALOG_LOCATION => 114 +, SQL_CATALOG_NAME_SEPARATOR => 41 +, SQL_CATALOG_TERM => 42 +, SQL_CONCAT_NULL_BEHAVIOR => 22 +, SQL_DATA_SOURCE_NAME => 2 +, SQL_DBMS_NAME => 17 +, SQL_DBMS_VER => 18 +, SQL_DBMS_VERSION => 18 +, SQL_DRIVER_NAME => 6 +, SQL_DRIVER_VER => 7 +, SQL_IDENTIFIER_CASE => 28 +, SQL_IDENTIFIER_QUOTE_CHAR => 29 +, SQL_KEYWORDS => 89 +, SQL_OWNER_TERM => 39 +, SQL_PROCEDURE_TERM => 40 +, SQL_QUALIFIER_LOCATION => 114 +, SQL_QUALIFIER_NAME_SEPARATOR => 41 +, SQL_QUALIFIER_TERM => 42 +, SQL_SCHEMA_TERM => 39 +, SQL_TABLE_TERM => 45 +, SQL_USER_NAME => 47
new file mode 100644 --- /dev/null +++ b/DBD/t/06ti.t @@ -0,0 +1,41 @@ +#!perl -I./t + +# This Source Code Form is subject to the terms of the Mozilla Public +# License, v. 2.0. If a copy of the MPL was not distributed with this +# file, You can obtain one at http://mozilla.org/MPL/2.0/. +# +# Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + +$| = 1; + +use strict; +use warnings; +use DBI (); + +use Test::More; + +if (defined $ENV{DBI_DSN}) { + plan tests => 5; +} else { + plan skip_all => 'Cannot test without DB info'; +} + +my $dbh = DBI->connect or die "Connect failed: $DBI::errstr\n"; +ok ( defined $dbh,'Connection'); + +my @ti = $dbh->type_info; +ok( @ti,'type_info'); +for my $ti ( @ti ) { + print "#\n"; + printf "# %-20s => %s\n", $_, DBI::neat( $ti->{$_} ) for sort keys %$ti; +} + +my $tia = $dbh->type_info_all; +is( ref $tia,'ARRAY','type_info_all'); + +my $idx = shift @$tia; +is( ref $idx,'HASH','index hash'); + +print '# ', DBI::neat_list( $_ ), "\n" for @$tia; + +ok( $dbh->disconnect,'Disconnect');
new file mode 100644 --- /dev/null +++ b/DBD/t/07q.t @@ -0,0 +1,54 @@ +#!perl -I./t + +# This Source Code Form is subject to the terms of the Mozilla Public +# License, v. 2.0. If a copy of the MPL was not distributed with this +# file, You can obtain one at http://mozilla.org/MPL/2.0/. +# +# Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + +$| = 1; + +use strict; +use warnings; +use DBI(); +use DBD_TEST(); + +use Test::More; + +if ( defined $ENV{DBI_DSN} ) { + plan tests => 12; +} else { + plan skip_all => 'Cannot test without DB info'; +} + +pass('Quote tests'); + +my $dbh = DBI->connect or die "Connect failed: $DBI::errstr\n"; + $dbh->{RaiseError} = 1; + $dbh->{PrintError} = 0; +pass('Database connection created'); + +eval { $dbh->quote }; +ok( $@,"Call to quote() with 0 arguments, error expected: $@"); + +my $val = +[ + [ 1 , q{'1'} ] +, [ 2 , q{'2'} ] +, [ undef , 'NULL' ] +, ['NULL' , q{'NULL'} ] +, ['ThisIsAString' , q{'ThisIsAString'} ] +, ['This is Another String', q{'This is Another String'} ] +, ["This isn't unusual" , q{'This isn''t unusual'} ] +]; +for ( @$val ) { + my $val0 = $_->[0]; + my $val1 = defined $val0 ? $val0 : 'undef'; + my $val2 = $dbh->quote( $val0 ); + is( $val2, $_->[1],"quote on $val1 returned $val2"); +} + +my $ti = DBD_TEST::get_type_for_column( $dbh,'A'); +is( $dbh->quote( 1, $ti->{DATA_TYPE} ), 1,"quote( 1, $ti->{DATA_TYPE} )"); + +ok( $dbh->disconnect,'Disconnect');
new file mode 100644 --- /dev/null +++ b/DBD/t/11prep.t @@ -0,0 +1,62 @@ +#!perl -I./t + +# This Source Code Form is subject to the terms of the Mozilla Public +# License, v. 2.0. If a copy of the MPL was not distributed with this +# file, You can obtain one at http://mozilla.org/MPL/2.0/. +# +# Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + +$| = 1; + +use strict; +use warnings; +use DBI(); +use DBD_TEST(); + +use Test::More; + +if (defined $ENV{DBI_DSN}) { + plan tests => 15; +} else { + plan skip_all => 'Cannot test without DB info'; +} + +pass('Simple prepare/execute/finish tests'); + +my $dbh = DBI->connect or die "Connect failed: $DBI::errstr\n"; +pass('Database connection created'); + +my $tbl = $DBD_TEST::table_name; + +{ + local ($dbh->{PrintError}, $dbh->{RaiseError}, $dbh->{Warn}); + $dbh->{PrintError} = 0; $dbh->{RaiseError} = 0; $dbh->{Warn} = 0; + $dbh->do("DROP TABLE $tbl"); +} + +ok( $dbh->disconnect,'Disconnect'); + +$dbh = DBI->connect or die "Connect failed: $DBI::errstr\n"; +pass('Database connection created'); +{ + local $dbh->{PrintError} = 0; + local $dbh->{RaiseError} = 1; + ok( !eval{ $dbh->do("DROP TABLE $tbl") },"DROP TABLE $tbl"); + print $@, "\n"; +} +ok( $dbh->do("CREATE TABLE $tbl( chr char( 1 ) )"),"CREATE TABLE $tbl"); + +my $sth; +ok( $sth = $dbh->prepare("SELECT * FROM $tbl"),"SELECT * FROM $tbl"); +ok( $sth->execute,'Execute'); +ok( $sth->finish,'Finish'); +ok( $sth = $dbh->prepare("SELECT * FROM $tbl"),"SELECT * FROM $tbl"); +ok( $sth->finish,'Finish'); +ok( $sth = $dbh->prepare("SELECT * FROM $tbl"),"SELECT * FROM $tbl"); +ok( !( $sth = undef ),'Set sth to undefined'); +#ok( $sth = $dbh->prepare("SELECT * FROM $tbl", { monetdb_ => ... } ),"SELECT * FROM $tbl ( monetdb_ => ... )"); +#ok( $sth->execute,'Execute'); +#ok( !( $sth = undef ),'Set sth to undefined'); +ok( $dbh->do("DROP TABLE $tbl"),"DROP TABLE $tbl"); + +ok( $dbh->disconnect,'Disconnect');
new file mode 100644 --- /dev/null +++ b/DBD/t/12bind.t @@ -0,0 +1,98 @@ +#!perl -I./t + +# This Source Code Form is subject to the terms of the Mozilla Public +# License, v. 2.0. If a copy of the MPL was not distributed with this +# file, You can obtain one at http://mozilla.org/MPL/2.0/. +# +# Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + +$| = 1; + +use strict; +use warnings; +use DBI(); +use DBD_TEST(); + +use Test::More; + +if (defined $ENV{DBI_DSN}) { + plan tests => 6; +} else { + plan skip_all => 'Cannot test without DB info'; +} + +my $dbh = DBI->connect or die "Connect failed: $DBI::errstr\n"; +ok ( defined $dbh, 'Connection'); + +ok( DBD_TEST::tab_create( $dbh ),"Create the test table $DBD_TEST::table_name"); + +my $data = +[ + [ 1,'foo' ,'me' x 120 ,'1998-05-13','1988-05-13 01:12:33'] +, [ 2,'bar' ,'bar varchar' ,'1998-05-14','1998-05-14 01:25:33'] +, [ 3,'bletch','bletch varchar','1998-05-15','1998-05-15 01:15:33'] +, [ 4,'bletch','me' x 14 ,'1998-05-15','1998-05-15 01:15:33'] +]; + +ok( tab_insert( $dbh, $data ),'Insert test data'); + +ok( tab_select( $dbh ),'Select test data'); + +ok( DBD_TEST::tab_delete( $dbh ),'Drop test table'); + +ok( $dbh->disconnect,'Disconnect'); + + +sub tab_select +{ + my $dbh = shift; + + my $sth = $dbh->prepare("SELECT A,B,C,D FROM $DBD_TEST::table_name WHERE a = ?") + or return undef; + my $ti = DBD_TEST::get_type_for_column( $dbh,'A'); + for my $v ( 1, 3, 2, 4, 10 ) { + $sth->bind_param( 1, $v, { TYPE => $ti->{DATA_TYPE} } ); + $sth->execute; + while ( my $row = $sth->fetch ) { + print "# -- $row->[0] length:", length $row->[1]," $row->[1] $row->[2] $row->[3]\n"; + if ( $row->[0] != $v ) { + print "# Bind value failed! bind value = $v, returned value = $row->[0]\n"; + return undef; + } + } + } + return 1; +} + +sub tab_insert +{ + my $dbh = shift; + my $data = shift; + + my $sth = $dbh->prepare("INSERT INTO $DBD_TEST::table_name (A, B, C, D) VALUES (?, ?, ?, ?)"); + unless ( $sth ) { + print $DBI::errstr; + return 0; + } + $sth->{PrintError} = 1; + for ( @$data ) { + my $ti; + + $ti = DBD_TEST::get_type_for_column( $dbh,'A'); + $sth->bind_param( 1, $_->[ 0], { TYPE => $ti->{DATA_TYPE} } ); + + $ti = DBD_TEST::get_type_for_column( $dbh,'B'); +# $_->[1] = $_->[1] x (int( int( $ti->{COLUMN_SIZE} / 2 ) / length( $_->[1] ) ) ); # XXX + $sth->bind_param( 2, $_->[ 1], { TYPE => $ti->{DATA_TYPE} } ); + + $ti = DBD_TEST::get_type_for_column( $dbh,'C'); + $sth->bind_param( 3, $_->[ 2], { TYPE => $ti->{DATA_TYPE} } ); + + $ti = DBD_TEST::get_type_for_column( $dbh,'D'); + my $i = ( $ti->{DATA_TYPE} == DBI::SQL_TYPE_DATE || $ti->{DATA_TYPE} == DBI::SQL_DATE ) ? 3 : 4; + $sth->bind_param( 4, $_->[$i], { TYPE => $ti->{DATA_TYPE} } ); + + return 0 unless $sth->execute; + } + 1; +}
new file mode 100644 --- /dev/null +++ b/DBD/t/12ins_b.t @@ -0,0 +1,56 @@ +#!perl -I./t + +# This Source Code Form is subject to the terms of the Mozilla Public +# License, v. 2.0. If a copy of the MPL was not distributed with this +# file, You can obtain one at http://mozilla.org/MPL/2.0/. +# +# Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + +$| = 1; + +use strict; +use warnings; +use DBI(); +use DBD_TEST(); + +use Test::More; + +my $tbl = $DBD_TEST::table_name; +my @col = sort keys %DBD_TEST::TestFieldInfo; +my $dat = [ + [ 1,'A123' ,'A' x 12,'1998-05-13'] +, [ 2,'B12' ,'B' x 2,'1998-05-14'] +, [ 3,'C1234' ,'C' x 22,'1998-05-15'] +, [ 4,'D12345','D' x 32,'1998-05-16'] +]; +if ( defined $ENV{DBI_DSN} ) { + plan tests => 4 + ( 3 + 3 * @$dat ) * @col; +} else { + plan skip_all => 'Cannot test without DB info'; +} + +pass('Insert tests'); + +my $dbh = DBI->connect or die "Connect failed: $DBI::errstr\n"; + $dbh->{RaiseError} = 1; + $dbh->{PrintError} = 0; + $dbh->{ChopBlanks} = 1; +pass('Database connection created'); + +ok( DBD_TEST::tab_create( $dbh ),"CREATE TABLE $tbl"); + +for my $i ( 0..$#col ) { + ok( $dbh->do( $_ ),"do $i: $_") for "DELETE FROM $tbl"; + my $ti = DBD_TEST::get_type_for_column( $dbh, $col[$i] ); + my $sth = $dbh->prepare("INSERT INTO $tbl( $col[$i] ) VALUES( ? )"); + ok( defined $sth,"prepare $i: $sth->{Statement}"); + for ( @$dat ) { + ok( $sth->bind_param( 1, $_->[$i], { TYPE => $ti->{DATA_TYPE} } ),"bind_param: $col[$i] => $_->[$i]"); + ok( $sth->$_, $_ ) for 'execute'; + } + my $a = $dbh->selectcol_arrayref("SELECT $col[$i] FROM $tbl"); + ok( defined $a,"selectcol_arrayref $i: $#$a"); + @$a = sort @$a; + is( $a->[$_], $dat->[$_][$i],"compare: $dat->[$_][$i]") for 0..$#$dat; +} +ok( $dbh->disconnect,'Disconnect');
new file mode 100644 --- /dev/null +++ b/DBD/t/12ins_q.t @@ -0,0 +1,54 @@ +#!perl -I./t + +# This Source Code Form is subject to the terms of the Mozilla Public +# License, v. 2.0. If a copy of the MPL was not distributed with this +# file, You can obtain one at http://mozilla.org/MPL/2.0/. +# +# Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + +$| = 1; + +use strict; +use warnings; +use DBI(); +use DBD_TEST(); + +use Test::More; + +my $tbl = $DBD_TEST::table_name; +my @col = sort keys %DBD_TEST::TestFieldInfo; +my $dat = [ + [ 1,'A123' ,'A' x 12,'1998-05-13'] +, [ 2,'B12' ,'B' x 2,'1998-05-14'] +, [ 3,'C1234' ,'C' x 22,'1998-05-15'] +, [ 4,'D12345','D' x 32,'1998-05-16'] +]; +if ( defined $ENV{DBI_DSN} ) { + plan tests => 4 + ( 2 + 2 * @$dat ) * @col; +} else { + plan skip_all => 'Cannot test without DB info'; +} + +pass('Insert tests (quoted literals)'); + +my $dbh = DBI->connect or die "Connect failed: $DBI::errstr\n"; + $dbh->{RaiseError} = 1; + $dbh->{PrintError} = 0; + $dbh->{ChopBlanks} = 1; +pass('Database connection created'); + +ok( DBD_TEST::tab_create( $dbh ),"CREATE TABLE $tbl"); + +for my $i ( 0..$#col ) { + ok( $dbh->do( $_ ),"do $i: $_") for "DELETE FROM $tbl"; + my $ti = DBD_TEST::get_type_for_column( $dbh, $col[$i] ); + for ( @$dat ) { + my $v = $dbh->quote( $_->[$i], $ti->{DATA_TYPE} ); + ok( $dbh->do( $_ ),"do $i: $_") for "INSERT INTO $tbl( $col[$i] ) VALUES( $v )"; + } + my $a = $dbh->selectcol_arrayref("SELECT $col[$i] FROM $tbl"); + ok( defined $a,"selectcol_arrayref $i: $#$a"); + @$a = sort @$a; + is( $a->[$_], $dat->[$_][$i],"compare: $dat->[$_][$i]") for 0..$#$dat; +} +ok( $dbh->disconnect,'Disconnect');
new file mode 100644 --- /dev/null +++ b/DBD/t/13count.t @@ -0,0 +1,58 @@ +#!perl -I./t + +# This Source Code Form is subject to the terms of the Mozilla Public +# License, v. 2.0. If a copy of the MPL was not distributed with this +# file, You can obtain one at http://mozilla.org/MPL/2.0/. +# +# Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + +$| = 1; + +use strict; +use warnings; +use DBI(); +use DBD_TEST(); + +use Test::More; + +if ( defined $ENV{DBI_DSN} ) { + plan tests => 30; +} else { + plan skip_all => 'Cannot test without DB info'; +} + +pass('Row count tests'); + +my $dbh = DBI->connect or die "Connect failed: $DBI::errstr\n"; + $dbh->{RaiseError} = 1; + $dbh->{PrintError} = 0; +pass('Database connection created'); + +my $tbl = $DBD_TEST::table_name; +my $cnt = 7; + +ok( DBD_TEST::tab_create( $dbh ),"CREATE TABLE $tbl"); + +is( $dbh->do("INSERT INTO $tbl( A, B ) VALUES( $_,'T$_')"), 1,"($_) Insert") + for 1..$cnt; + +my $sth = $dbh->prepare("SELECT * FROM $tbl"); +is( $sth->rows, -1,'Rows (prepare) :'. $sth->rows ); + +for ( 1..2 ) { # (re)execute + $sth->execute; +# is( $sth->rows, 0,'Rows (execute) : '. $sth->rows ); + my $i = 0; + while ( my $row = $sth->fetch ) { + is( $sth->rows, ++$i,"($_) Rows so far: $i"); +# print "# Row $i: ", DBI::neat_list( $row ),"\n"; + } + is( $sth->rows, $cnt,"($_) Rows total : $cnt"); +} + +#$sth = $dbh->prepare("SELECT count(*) FROM $tbl"); + +is( $dbh->do("DELETE FROM $tbl"), $cnt,"Delete: $cnt"); +is( $dbh->do("DELETE FROM $tbl"),'0E0',"Delete: 0E0"); + +ok( $dbh->disconnect,'Disconnect');
new file mode 100644 --- /dev/null +++ b/DBD/t/14rows.t @@ -0,0 +1,118 @@ +#!perl -I./t + +# This Source Code Form is subject to the terms of the Mozilla Public +# License, v. 2.0. If a copy of the MPL was not distributed with this +# file, You can obtain one at http://mozilla.org/MPL/2.0/. +# +# Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + +$| = 1; + +use strict; +use warnings; +use DBI(); +use DBD_TEST(); +use Time::HiRes qw(gettimeofday tv_interval); + +use Test::More; + +if (defined $ENV{DBI_DSN}) { + plan tests => 18; +} else { + plan skip_all => 'Cannot test without DB info'; +} + +pass('Insert tests'); + +my $tbl1 = $DBD_TEST::table_name; +my $tbl2 = $tbl1 . '_2'; + +my $MAX_ROWS = 200; + +my $dbh = DBI->connect or die "Connect failed: $DBI::errstr\n"; +pass('Database connection created'); + +ok( DBD_TEST::tab_create( $dbh, $tbl1 ),"Create table $tbl1"); +ok( DBD_TEST::tab_create( $dbh, $tbl2 ),"Create table $tbl2"); + +# for my $ac ( 0, 1 ) { +# pass("Testing with AutoCommit $ac"); +# $dbh->{AutoCommit} = $ac; +# +# # Time how long it takes to run the insert test. +# my $t_beg = [gettimeofday]; +# run_insert_test( $dbh ); +# +# my $elapsed = tv_interval( $t_beg, [gettimeofday] ); +# +# pass("Run insert test: MAX_ROWS elapsed: $elapsed"); +# +# ok( $dbh->do( "DROP TABLE $tbl1"),"Drop table $tbl1"); +# } + +# Time how long it takes to run the insert test. +$dbh->{AutoCommit} = 0; +my $t_beg = [gettimeofday]; +run_insert_test( $dbh, $tbl1 ); + +my $elapsed = tv_interval( $t_beg, [gettimeofday] ); +pass("Run insert test: MAX_ROWS elapsed: $elapsed"); + +# Test the number of rows returned by an execute. +my $sql = <<"SQL"; +INSERT + INTO $tbl2( A, B ) +SELECT A, B + FROM $tbl1 +SQL + +my $sth = $dbh->prepare( $sql ); +ok( defined $sth,'Prepared insert select statement'); +my $rc = $sth->execute; +ok( !ref $rc,"Not a ref?"); +is( $rc, $MAX_ROWS,"Execute returned $MAX_ROWS rows"); +is( $sth->rows, $rc,"Execute sth->rows returned $rc"); + +$sth->finish; $sth = undef; + +# Test the number of rows returned by a do. +$rc = $dbh->do( $sql ); +is( $rc, $MAX_ROWS,"Do returned $MAX_ROWS rows"); + +$dbh->rollback; + +$dbh->{AutoCommit} = 1; + +ok( $dbh->do("DROP TABLE $tbl1"),"Drop table $tbl1"); +ok( $dbh->do("DROP TABLE $tbl2"),"Drop table $tbl2"); + +ok( $dbh->disconnect,'Disconnect'); + + +sub run_insert_test { + my $dbh = shift; + my $tbl = shift; + + my $sth = $dbh->prepare("INSERT INTO $tbl( B ) VALUES( ? )"); + ok( defined $sth,'Insert statement prepared'); + ok( !$dbh->err,'No error on prepare.'); + + pass("Loading rows into table: $tbl"); + + my $cnt = 0; my $added = 0; + my $ac = $dbh->{AutoCommit}; + while( $cnt < $MAX_ROWS ) { + $added += ( $sth->execute("Just a text message for $cnt") || 0 ); + } continue { + $cnt++; + $dbh->commit if $ac == 0 && $cnt % 1000 == 0; + print "# Checkpoint: $cnt\n" if $cnt % 1000 == 0; + } + $dbh->commit if $ac == 0; + + ok( $added > 0,"Added $added rows to test using count of $cnt"); + ok( $added == $MAX_ROWS,"Added MAX $MAX_ROWS rows to test using count of $cnt"); + + $sth->finish; $sth = undef; + return; +}
new file mode 100644 --- /dev/null +++ b/DBD/t/18bc.t @@ -0,0 +1,98 @@ +#!perl -I./t + +# This Source Code Form is subject to the terms of the Mozilla Public +# License, v. 2.0. If a copy of the MPL was not distributed with this +# file, You can obtain one at http://mozilla.org/MPL/2.0/. +# +# Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + +$| = 1; + +use strict; +use warnings; +use DBI(); +use DBD_TEST(); + +use Test::More; + +if (defined $ENV{DBI_DSN}) { + plan tests => 8; +} else { + plan skip_all => 'Cannot test without DB info'; +} + +pass('Bind column tests'); + +my $dbh = DBI->connect or die "Connect failed: $DBI::errstr\n"; +pass('Database connection created'); + +my $tbl = $DBD_TEST::table_name; + +ok( DBD_TEST::tab_create( $dbh ),"CREATE TABLE $tbl"); + +$dbh->{AutoCommit} = 0; + +$dbh->do("INSERT INTO $tbl( A, B ) VALUES( 10,'Stuff here')"); + +$dbh->commit; + +my $sth; + +$sth = $dbh->prepare("DELETE FROM $tbl"); +$sth->execute; +my $s = $sth->rows; +my $t = $DBI::rows; +is( $s, $t,"sth->rows: $s DBI::rows: $t"); + +$dbh->rollback; + +$sth = $dbh->prepare("SELECT * FROM $tbl WHERE 1 = 0"); +$sth->execute; +my @row = $sth->fetchrow; +if ( $sth->err ) { + print ' $sth->err : ', $sth->err , "\n"; + print ' $sth->errstr: ', $sth->errstr, "\n"; + print ' $dbh->state : ', $dbh->state , "\n"; +# print ' $sth->state : ', $sth->state , "\n"; +} +pass("Fetched empty result set: (@row)"); + +$sth = $dbh->prepare("SELECT A, B FROM $tbl"); +$sth->execute; +while ( my $row = $sth->fetch ) { + print '# @row a, b : ', $row->[0], ',', $row->[1], "\n"; +} + +my $Ok; + +$Ok = 1; +my ( $a, $b ); +$sth->execute; +$sth->bind_col( 1, \$a ); +$sth->bind_col( 2, \$b ); +while ( $sth->fetch ) { + print '# bind_col a, b : ', $a, ',', $b, "\n"; + unless ( defined $a && defined $b ) { + $Ok = 0; + $sth->finish; + last; + } +} +is( $Ok, 1,'All fields defined'); + +$Ok = 1; +( $a, $b ) = ( undef, undef ); +$sth->execute; +$sth->bind_columns( undef, \$b, \$a ); +while ( $sth->fetch ) +{ + print '# bind_columns a, b : ', $b, ',', $a, "\n"; + unless ( defined $a && defined $b ) { + $Ok = 0; + $sth->finish; + last; + } +} +is( $Ok, 1,'All fields defined'); + +ok( $dbh->disconnect,'Disconnect');
new file mode 100644 --- /dev/null +++ b/DBD/t/21sth.t @@ -0,0 +1,90 @@ +#!perl -I./t + +# This Source Code Form is subject to the terms of the Mozilla Public +# License, v. 2.0. If a copy of the MPL was not distributed with this +# file, You can obtain one at http://mozilla.org/MPL/2.0/. +# +# Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + +$| = 1; + +use strict; +use warnings; +use DBI(); +use DBD_TEST(); + +use Test::More; + +if (defined $ENV{DBI_DSN}) { + plan tests => 30; +} else { + plan skip_all => 'Cannot test without DB info'; +} + +pass('Attribute tests'); + +my $dbh = DBI->connect or die "Connect failed: $DBI::errstr\n"; +pass('Database connection created'); + +my $tbl = $DBD_TEST::table_name; + +ok( DBD_TEST::tab_create( $dbh ),"CREATE TABLE $tbl"); + +my $sth = $dbh->prepare("SELECT A FROM $tbl"); +ok( defined $sth,'Statement handle defined'); + +ok(!$sth->{$_},"$_: $sth->{$_}") for 'Active'; +ok( $sth->$_, $_ ) for 'execute'; +ok( $sth->{$_},"$_: $sth->{$_}") for 'Active'; + +# TODO: +# +# DBI 1.43: getting or setting an invalid attribute to no longer be +# a fatal error but generate a warning instead. +#eval { +# my $val = $sth->{BadAttributeHere}; +#}; +#ok( $@,"Statement attribute BadAttributeHere: $@"); + +my @attribs = qw( +NUM_OF_FIELDS +NUM_OF_PARAMS +NAME NAME_lc +NAME_uc +PRECISION +SCALE +NULLABLE +CursorName +Statement +RowsInCache +); + +for my $attrib ( sort @attribs ) { + eval { + my $val = $sth->{$attrib}; + }; + ok(!$@,"Statement attribute: $attrib"); +} + +my $val = -1; +# TODO: ok( $val = ( $sth->{RowsInCache} = 100 ),"Setting RowsInCache : $val"); +# TODO: ok( ($val = $sth->{RowsInCache} ) == 100 ,"Getting RowsInCache : $val"); + +is( ref $sth->{NAME},'ARRAY','ref $sth->{NAME} is ARRAY'); +is( @{$sth->{NAME}}, 1,'$sth->{NAME} has 1 element'); +is( uc $sth->{NAME}[0],'A','1st element is "A"'); +is( $sth->{NUM_OF_FIELDS}, 1,'$sth->{NUM_OF_FIELDS} is 1'); + +ok( $sth->$_, $_ ) for 'finish'; +ok(!$sth->{$_},"$_: $sth->{$_}") for 'Active'; +{ + my $sth = $dbh->prepare("SELECT A FROM $tbl"); + ok( defined $sth,'Statement handle defined'); + + ok(!$sth->{$_},"$_: $sth->{$_}") for 'Active'; + ok( $sth->$_, $_ ) for 'execute'; + ok( $sth->{$_},"$_: $sth->{$_}") for 'Active'; + 1 while $sth->fetch; + ok(!$sth->{$_},"$_: $sth->{$_}") for 'Active'; +} +ok( $dbh->disconnect,'Disconnect');
new file mode 100644 --- /dev/null +++ b/DBD/t/23null.t @@ -0,0 +1,51 @@ +#!perl -I./t + +# This Source Code Form is subject to the terms of the Mozilla Public +# License, v. 2.0. If a copy of the MPL was not distributed with this +# file, You can obtain one at http://mozilla.org/MPL/2.0/. +# +# Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + +$| = 1; + +use strict; +use warnings; +use DBI(); +use DBD_TEST(); + +use Test::More; + +if ( defined $ENV{DBI_DSN} ) { + plan tests => 14; +} else { + plan skip_all => 'Cannot test without DB info'; +} + +pass('NULL tests'); + +my $dbh = DBI->connect or die "Connect failed: $DBI::errstr\n"; + $dbh->{RaiseError} = 1; + $dbh->{PrintError} = 0; +pass('Database connection created'); + +my $tbl = $DBD_TEST::table_name; +my @col = sort keys %DBD_TEST::TestFieldInfo; + +ok( DBD_TEST::tab_create( $dbh ),"CREATE TABLE $tbl"); + +ok( $dbh->do("INSERT INTO $tbl( $_ ) VALUES( ? )", undef, undef ),"Inserting NULL into $_") + for @col; + +my $Cols = join ', ', @col; +my $Qs = join ', ', map {'?'} @col; +my $sth = $dbh->prepare("INSERT INTO $tbl( $Cols ) VALUES( $Qs )"); +ok( defined $sth,'Prepare insert statement'); + +my $i = 0; +for ( @col ) { + my $ti = DBD_TEST::get_type_for_column( $dbh, $_ ); + ok( $sth->bind_param( ++$i, undef, { TYPE => $ti->{DATA_TYPE} } ),"Bind parameter for column $_"); +} +ok( $sth->execute,'Execute prepared statement with bind params'); + +ok( $dbh->disconnect,'Disconnect');
new file mode 100644 --- /dev/null +++ b/DBD/t/31txn.t @@ -0,0 +1,96 @@ +#!perl -I./t + +# This Source Code Form is subject to the terms of the Mozilla Public +# License, v. 2.0. If a copy of the MPL was not distributed with this +# file, You can obtain one at http://mozilla.org/MPL/2.0/. +# +# Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + +$| = 1; + +use strict; +use warnings; +use DBI(); +use DBD_TEST(); + +use Test::More; + +if ( defined $ENV{DBI_DSN} ) { + plan tests => 19; +} else { + plan skip_all => 'Cannot test without DB info'; +} + +my $tbl = $DBD_TEST::table_name; + +pass('Transaction / AutoCommit tests'); + +my $dbh = DBI->connect or die "Connect failed: $DBI::errstr\n"; + $dbh->{RaiseError} = 1; + $dbh->{PrintError} = 0; +pass('Database connection created'); + +for ('rollback','commit') +{ + my $Warning; + local $SIG{__WARN__} = sub { $Warning = $_[0]; chomp $Warning; }; + local $dbh->{Warn} = 1; + $dbh->$_; + like( $Warning, qr/ineffective/, "Warning expected: $Warning"); +} +ok( DBD_TEST::tab_create( $dbh ),"CREATE TABLE $tbl"); + +$dbh->{AutoCommit} = 1; +ok( $dbh->{AutoCommit}, "AutoCommit ON: $dbh->{AutoCommit}"); + +is( commitTest( $dbh ), 1,'Commit Test, AutoCommit ON'); + +$dbh->{AutoCommit} = 0; +ok( !$dbh->{AutoCommit}, "AutoCommit OFF: $dbh->{AutoCommit}"); + +is( commitTest( $dbh ), 0,'Commit Test, AutoCommit OFF'); + +$dbh->{AutoCommit} = 1; +ok( $dbh->{AutoCommit}, "AutoCommit ON: $dbh->{AutoCommit}"); + +is( commitTest( $dbh ), 1,'Commit Test, AutoCommit ON'); + +ok( $dbh->begin_work ,'begin_work'); +ok( $dbh->{BegunWork} ,'BegunWork ON'); +ok(!$dbh->{AutoCommit},'AutoCommit OFF'); +ok( $dbh->rollback ,'rollback'); +ok(!$dbh->{BegunWork} ,'BegunWork OFF'); +ok( $dbh->{AutoCommit},'AutoCommit ON'); + +ok( $dbh->do("DROP TABLE $tbl"),"DROP TABLE $tbl"); + +ok( $dbh->disconnect,'Disconnect'); + +# ----------------------------------------------------------------------------- +# Returns true when a row remains inserted after a rollback. +# This means that AutoCommit is ON. +# ----------------------------------------------------------------------------- +sub commitTest { + my $dbh = shift; + + $dbh->do("DELETE FROM $tbl WHERE A = 100") or return undef; + { + local $SIG{__WARN__} = sub {}; # suppress the "commit ineffective" warning + local $dbh->{RaiseError} = 0; + $dbh->commit; + } + $dbh->do("INSERT INTO $tbl( A, B ) VALUES( 100,'T100')"); + { + local $SIG{__WARN__} = sub {}; # suppress the "rollback ineffective" warning + local $dbh->{RaiseError} = 0; + $dbh->rollback; + } + my $sth = $dbh->prepare("SELECT A, B FROM $tbl WHERE A = 100"); + $sth->execute; + my $rc = 0; + while ( my $row = $sth->fetch ) { + print "-- @$row\n"; + $rc = 1; + } + $rc; +}
new file mode 100644 --- /dev/null +++ b/DBD/t/41ddtbl.t @@ -0,0 +1,171 @@ +#!perl -I./t + +# This Source Code Form is subject to the terms of the Mozilla Public +# License, v. 2.0. If a copy of the MPL was not distributed with this +# file, You can obtain one at http://mozilla.org/MPL/2.0/. +# +# Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + +$| = 1; + +use strict; +use warnings; +use DBI(); +use DBD_TEST(); + +use Test::More; + +if (defined $ENV{DBI_DSN}) { + plan tests => 26; +} else { + plan skip_all => 'Cannot test without DB info'; +} + +pass('Table info tests'); + +my $dbh = DBI->connect or die "Connect failed: $DBI::errstr\n"; +pass('Database connection created'); + +my $tbl = lc $DBD_TEST::table_name; + +ok( DBD_TEST::tab_create( $dbh ),"CREATE TABLE $tbl"); +{ + my @names = qw(TABLE_CAT TABLE_SCHEM TABLE_NAME TABLE_TYPE REMARKS); + my $sth = $dbh->table_info; + my $rows = 0; + while ( my $row = $sth->fetch ) { + $rows++; + } + my $names = $sth->{NAME_uc}; + is( $names->[$_], $names[$_],"Column: $names->[$_] $names[$_]") + for 0 .. $#names; + + is( $dbh->tables, $rows,"Total tables count: $rows"); +} +{ + my $sth = $dbh->table_info( undef, undef, undef,'TABLE'); + ok( defined $sth,'Statement handle defined'); + + my $row = $sth->fetch; + is( $row->[3],'TABLE','Fetched a TABLE?'); +} +{ + my $sth = $dbh->table_info( undef, undef, $tbl,'TABLE'); + ok( defined $sth,'Statement handle defined'); + + my $row = $sth->fetch; + is( $row->[2], $tbl,"Is this $tbl?"); + is( $row->[3],'TABLE',"Is $tbl a TABLE?"); +} +{ + my $sth = $dbh->table_info( undef, undef, $tbl,'VIEW'); + ok( defined $sth,'Statement handle defined'); + + my $row = $sth->fetch; + ok( !defined $row,"$tbl isn't a VIEW!"); +} +=for todo +{ + my $sth = $dbh->table_info('%'); + ok( defined $sth,'Statement handle defined'); + + print "Catalogs:\n"; + while ( my $row = $sth->fetch ) + { + local $^W = 0; + local $, = "\t"; + print @$row,"\n"; + } +} +{ + my $sth = $dbh->table_info( undef,'%'); + ok( defined $sth,'Statement handle defined'); + + print "Schemata:\n"; + while ( my $row = $sth->fetch ) + { + local $^W = 0; + local $, = "\t"; + print @$row,"\n"; + } +} +{ + my $sth = $dbh->table_info( undef, undef, undef,'%'); + ok( defined $sth,'Statement handle defined'); + + print "Table types:\n"; + while ( my $row = $sth->fetch ) + { + local $^W = 0; + local $, = "\t"; + print @$row,"\n"; + } +} +=cut + +# ----------------------------------------------------------------------------- +{ +my $sth; + +# Table Info +eval { + $sth = $dbh->table_info; +}; +ok( (!$@ and defined $sth ),'table_info tested'); +$sth = undef; + +# Tables +eval { + $sth = $dbh->tables; +}; +ok( (!$@ and defined $sth ),'tables tested'); +$sth = undef; + +# Test Table Info +$sth = $dbh->table_info( undef, undef, undef ); +ok( defined $sth,'table_info( undef, undef, undef ) tested'); +DBD_TEST::dump_results( $sth ); +$sth = undef; + +$sth = $dbh->table_info( undef, undef, undef,'VIEW'); +ok( defined $sth, q(table_info( undef, undef, undef,'VIEW') tested) ); +DBD_TEST::dump_results( $sth ); +$sth = undef; + +# Test Table Info Rule 19a +$sth = $dbh->table_info('%','',''); +ok( defined $sth, q(table_info('%','','') tested) ); +DBD_TEST::dump_results( $sth ); +$sth = undef; + +# Test Table Info Rule 19b +$sth = $dbh->table_info('','%',''); +ok( defined $sth, q(table_info('','%','') tested) ); +DBD_TEST::dump_results( $sth ); +$sth = undef; + +# Test Table Info Rule 19c +$sth = $dbh->table_info('','','','%'); +ok( defined $sth, q(table_info('','','','%') tested) ); +DBD_TEST::dump_results( $sth ); +$sth = undef; + +# Test to see if this database contains any of the defined table types. +$sth = $dbh->table_info('','','','%'); +ok( defined $sth, q(table_info('','','','%') tested) ); +if ( $sth ) { + my $err = 0; + my $ref = $sth->fetchall_hashref(lc 'TABLE_TYPE'); + for my $type ( sort keys %$ref ) { + print "# $type:\n"; + my $sth = $dbh->table_info( undef, undef, undef, $type ) or $err++; + DBD_TEST::dump_results( $sth ); + } + is( $err, 0,'all table types selected'); +} +$sth = undef; + +} +# ----------------------------------------------------------------------------- + +ok( $dbh->disconnect,'Disconnect');
new file mode 100644 --- /dev/null +++ b/DBD/t/42ddcol.t @@ -0,0 +1,74 @@ +#!perl -I./t + +# This Source Code Form is subject to the terms of the Mozilla Public +# License, v. 2.0. If a copy of the MPL was not distributed with this +# file, You can obtain one at http://mozilla.org/MPL/2.0/. +# +# Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + +$| = 1; + +use strict; +use warnings; +use DBI(); +use DBD_TEST(); + +use Test::More; + +if (defined $ENV{DBI_DSN}) { + plan tests => 25; +} else { + plan skip_all => 'Cannot test without DB info'; +} + +pass('Column info tests'); + +my $dbh = DBI->connect or die "Connect failed: $DBI::errstr\n"; +pass('Database connection created'); + +my $tbl = lc $DBD_TEST::table_name; + +{ + ok( DBD_TEST::tab_create( $dbh ),"CREATE TABLE $tbl"); +} +# TODO: handle catalog and schema ($tbl may exist in more then one schema) +{ + my $sth; + + eval { $sth = $dbh->column_info( undef, undef, undef, undef ) }; + ok( (!$@ and defined $sth ),'column_info tested'); + $sth = undef; +} +{ + my $sth = $dbh->column_info( undef, undef, $tbl,'b'); + ok( defined $sth,'Statement handle defined'); + + my $row = $sth->fetch; + is( $row->[ 2], $tbl,"Is this table name $tbl?"); + is( $row->[ 3], 'b','Is this column name b?'); +} +{ + my $sth = $dbh->column_info( undef, undef, $tbl, undef ); + ok( defined $sth,'Statement handle defined'); + + my @ColNames = sort keys %DBD_TEST::TestFieldInfo; + print "# Columns:\n"; + my $i = 0; + while ( my $row = $sth->fetch ) + { + $i++; + { + no warnings 'uninitialized'; + local $, = ":"; print '# ', @$row, "\n"; + } + $row->[ 3] = uc $row->[ 3]; + is( $row->[ 2], $tbl ,"Is this table name $tbl?"); + is( $row->[16], $i ,"Is this ordinal position $i?"); + is( $row->[ 3], $ColNames[$i-1] ,"Is this column name $ColNames[$i-1]?"); + my $ti = DBD_TEST::get_type_for_column( $dbh, $row->[3] ); +# is( $row->[ 4] , $ti->{DATA_TYPE},"Is this data type $ti->{DATA_TYPE}?"); + is( $row->[ 5] , $ti->{TYPE_NAME},"Is this type name $ti->{TYPE_NAME}?"); + } +} + +ok( $dbh->disconnect,'Disconnect');
new file mode 100644 --- /dev/null +++ b/DBD/t/43ddpk.t @@ -0,0 +1,119 @@ +#!perl -I./t + +# This Source Code Form is subject to the terms of the Mozilla Public +# License, v. 2.0. If a copy of the MPL was not distributed with this +# file, You can obtain one at http://mozilla.org/MPL/2.0/. +# +# Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + +$| = 1; + +use strict; +use warnings; +use DBI(); +use DBD_TEST(); + +use Test::More; + +if (defined $ENV{DBI_DSN}) { + plan tests => 19; +} else { + plan skip_all => 'Cannot test without DB info'; +} + +pass('Primary key tests'); + +my $dbh = DBI->connect or die "Connect failed: $DBI::errstr\n"; +pass('Database connection created'); + +eval { $dbh->primary_key_info }; +ok( $@,"Call to primary_key_info with 0 arguments, error expected: $@"); + +eval { $dbh->primary_key }; +ok( $@,"Call to primary_key with 0 arguments, error expected: $@"); + +{ + local $dbh->{PrintError} = 0; + + my $sth = $dbh->primary_key_info( undef, undef, ''); + ok( $dbh->err,'Call to primary_key with undefined schema argument, error expected: ' . $dbh->errstr ); + + $sth = $dbh->primary_key_info( undef,'', undef ); + ok( $dbh->err,'Call to primary_key with undefined table argument, error expected: ' . $dbh->errstr ); +} +# ----------------------------------------------------------------------------- + +my $catalog = undef; +my $schema = $dbh->selectrow_array(<<'SQL'); +select name from sys.schemas where name = current_schema +SQL +ok( $schema,"Current schema: $schema"); +my $tbl = lc $DBD_TEST::table_name; + +my $ti = DBD_TEST::get_type_for_column( $dbh,'A'); +is( ref $ti,'HASH','Type info'); + +{ + local ($dbh->{Warn}, $dbh->{PrintError}); + $dbh->{PrintError} = $dbh->{Warn} = 0; + $dbh->do("DROP TABLE $tbl"); +} +# ----------------------------------------------------------------------------- +SKIP: { + my $sql = <<"SQL"; +CREATE TABLE $tbl +( + K1 $ti->{TYPE_NAME} PRIMARY KEY +, K2 $ti->{TYPE_NAME} +) +SQL + $dbh->do( $sql ); + is( $dbh->err, undef,"$sql"); + + skip('PK test 1', 4 ) if $dbh->err; + + my $sth = $dbh->primary_key_info( $catalog, $schema, $tbl ); + ok( defined $sth,'Statement handle defined'); + + my $a = $sth->fetchall_arrayref; + + print "# Primary key columns:\n"; + print '# ', DBI::neat_list( $_ ), "\n" for @$a; + + is( $#$a, 0,'Exactly one primary key column'); + is( uc( $a->[0][3] ),'K1', 'Primary key column name'); + + ok( $dbh->do( $_ ), $_ ) for "DROP TABLE $tbl"; +} +# ----------------------------------------------------------------------------- +SKIP: { + my $sql = <<"SQL"; +CREATE TABLE $tbl +( + K1 $ti->{TYPE_NAME} +, K2 $ti->{TYPE_NAME} +, PRIMARY KEY ( K1, K2 ) +) +SQL + { + local $dbh->{PrintError} = 0; + $dbh->do( $sql ); + } + is( $dbh->err, undef,"$sql"); + + skip('PK test 2', 4 ) if $dbh->err; + + my $sth = $dbh->primary_key_info( $catalog, $schema, $tbl ); + ok( defined $sth,'Statement handle defined'); + + my $a = $sth->fetchall_arrayref; + + print "# Primary key columns:\n"; + print '# ', DBI::neat_list( $_ ), "\n" for @$a; + + is( $#$a, 1,'Exactly two primary key columns'); + is( uc( $a->[$_-1][3] ),"K$_","Primary key column name: K$_") for 1, 2; +} +# ----------------------------------------------------------------------------- + +ok( $dbh->disconnect,'Disconnect');
new file mode 100644 --- /dev/null +++ b/DBD/t/44ddfk.t @@ -0,0 +1,113 @@ +#!perl -I./t + +# This Source Code Form is subject to the terms of the Mozilla Public +# License, v. 2.0. If a copy of the MPL was not distributed with this +# file, You can obtain one at http://mozilla.org/MPL/2.0/. +# +# Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + +$| = 1; + +use strict; +use warnings; +use DBI(); +use DBD_TEST(); + +use Test::More; + +if (defined $ENV{DBI_DSN}) { + plan tests => 14; +} else { + plan skip_all => 'Cannot test without DB info'; +} + +pass('Foreign key tests'); + +my $dbh = DBI->connect or die "Connect failed: $DBI::errstr\n"; +pass('Database connection created'); + +eval { $dbh->foreign_key_info }; +ok( $@,"Call to foreign_key_info with 0 arguments, error expected: $@"); + +{ + local $dbh->{PrintWarn} = 0; + +# my $sth = $dbh->foreign_key_info('', undef, undef, undef, undef, undef ); +# ok( $dbh->errstr,'Call to foreign_key_info with catalog argument, warning expected: ' . $dbh->errstr ); +} +# ----------------------------------------------------------------------------- + +my $catalog = undef; +my $schema = $dbh->selectrow_array(<<'SQL'); +select name from sys.schemas where name = current_schema +SQL +ok( $schema,"Current schema: $schema"); +my $tbl = lc $DBD_TEST::table_name; +my $tbl2 = $tbl . '_2'; + +my $ti = DBD_TEST::get_type_for_column( $dbh,'A'); +is( ref $ti,'HASH','Type info'); + +{ + local ($dbh->{Warn}, $dbh->{PrintError}); + $dbh->{PrintError} = $dbh->{Warn} = 0; + $dbh->do("DROP TABLE $tbl2"); + $dbh->do("DROP TABLE $tbl"); +} +# ----------------------------------------------------------------------------- +SKIP: { + my $sql = <<"SQL"; +create table $tbl +( + n integer +, s varchar(9) +, d date +, constraint pk_t primary key ( n, s ) +, constraint uk_t unique ( d ) +) +SQL + $dbh->do( $sql ); + is( $dbh->err, undef,"$sql"); + + skip('FK test 1', 4 ) if $dbh->err; + + $sql = <<"SQL"; +create table $tbl2 +( + n2 integer +, s2 varchar(9) +, d2 date +, constraint pk2_t primary key ( n2, s2 ) +, constraint uk2_t unique ( d2 ) +, constraint fkp_t foreign key ( n2, s2 ) references $tbl +, constraint fku_t foreign key ( d2 ) references $tbl( d ) +) +SQL + $dbh->do( $sql ); + is( $dbh->err, undef,"$sql"); + + my $sth = $dbh->foreign_key_info( $catalog, $schema, $tbl, $catalog, $schema, $tbl2 ); + ok( defined $sth,'Statement handle defined'); + + my $a = $sth->fetchall_arrayref; + + print "# Foreign key columns:\n"; + print '# ', DBI::neat_list( $_ ), "\n" for @$a; + + is( $#$a, 2,'Exactly 3 foreign key columns'); + is( $a->[2][3],'s', 'Foreign key column name'); + + ok( $dbh->do( $_ ), $_ ) for "DROP TABLE $tbl2"; + ok( $dbh->do( $_ ), $_ ) for "DROP TABLE $tbl"; +} +# ----------------------------------------------------------------------------- +SKIP: { + skip('Invalid use of null pointer (SQL-HY009) when using DBD::ODBC', 1 ) + if $dbh->{Driver}{Name} eq 'ODBC'; + my $sth = $dbh->foreign_key_info( undef, undef, undef, undef, undef, undef ); + ok( defined $sth,'Statement handle defined for foreign_key_info()'); + DBD_TEST::dump_results( $sth ); +} +# ----------------------------------------------------------------------------- + +ok( $dbh->disconnect,'Disconnect');
new file mode 100644 --- /dev/null +++ b/DBD/t/51qi.t @@ -0,0 +1,61 @@ +#!perl -I./t + +# This Source Code Form is subject to the terms of the Mozilla Public +# License, v. 2.0. If a copy of the MPL was not distributed with this +# file, You can obtain one at http://mozilla.org/MPL/2.0/. +# +# Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + +$| = 1; + +use strict; +use warnings; +use DBI(); +use DBD_TEST(); + +use Test::More; + +if ( defined $ENV{DBI_DSN} ) { + plan tests => 9; +} else { + plan skip_all => 'Cannot test without DB info'; +} + +pass('Quote identifier tests'); + +my $dbh = DBI->connect or die "Connect failed: $DBI::errstr\n"; + $dbh->{RaiseError} = 1; + $dbh->{PrintError} = 0; +pass('Database connection created'); + +my $tbl = lc $DBD_TEST::table_name; + +ok( DBD_TEST::tab_create( $dbh ),"CREATE TABLE $tbl"); + +eval { $dbh->quote_identifier }; +ok( $@,"Call to quote_identifier with 0 arguments, error expected: $@"); +{ + my $cst = $dbh->quote_identifier('catalog','schema','table'); + ok( $cst,"Test quote: $cst"); +} +my @cst; +{ + my $sth = $dbh->table_info( undef, undef, $tbl,'TABLE'); + ok( defined $sth,"Called table_info for $tbl"); + + my $row = $sth->fetch; + @cst = @$row[0,1,2]; +} +{ + my $cst = $dbh->quote_identifier( @cst ); + ok( $cst,"Test quote from table_info: $cst"); + + my $sth = $dbh->prepare("SELECT * FROM $cst"); + ok( $sth,"SELECT * FROM $cst prepared"); + $sth->execute; + while ( my $row = $sth->fetch ) { + print '-- ', DBI::neat_list( $row ),"\n"; + } +} + +ok( $dbh->disconnect,'Disconnect');
new file mode 100644 --- /dev/null +++ b/DBD/t/75mil.t @@ -0,0 +1,71 @@ +#!perl -I./t + +# This Source Code Form is subject to the terms of the Mozilla Public +# License, v. 2.0. If a copy of the MPL was not distributed with this +# file, You can obtain one at http://mozilla.org/MPL/2.0/. +# +# Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + +$| = 1; + +use strict; +use warnings; +use DBI(); +use DBD_TEST(); + +use Test::More; + +if (defined $ENV{DBI_DSN}) { + if ($ENV{DBI_DSN} =~ /dbi:monetdb:/) { + plan tests => 30; + } else { + plan skip_all => 'dbi:monetdb: specific tests'; + } +} else { + plan skip_all => 'Cannot test without DB info'; +} + +pass('MIL tests'); + +$ENV{DBI_DSN} .= ';language=mil'; + +my $dbh = DBI->connect or die "Connect failed: $DBI::errstr\n"; +pass('Database connection created'); + +for ( 7 .. 9 ) +{ + my $sth = $dbh->prepare("print( $_ );"); + ok( defined $sth,'Statement handle defined'); + ok( $sth->execute,'execute'); + my $row = $sth->fetch; + is( $#$row, 0,'last index'); + is( $row->[0], $_,'field 0'); +} +{ + local $dbh->{PrintError} = 0; + my $sth = $dbh->prepare('( xyz 1);'); + ok(!$sth->execute,'execute'); + like( $sth->errstr, qr/!ERROR:/,'Error expected'); +} +ok( $dbh->do( $_ ), $_) for 'var b := new( int, str );'; +ok( $dbh->do( $_ ), $_) for 'insert( b, 3,"T3");'; +{ + my $sth = $dbh->prepare('insert( b, ?, ? );'); + ok( defined $sth,'Statement handle defined'); + ok( $sth->bind_param( 1, 7 , DBI::SQL_INTEGER() ),'bind'); + ok( $sth->bind_param( 2,'T7' ),'bind'); + ok( $sth->execute,'execute'); +} +{ + my $sth = $dbh->prepare('print( b );'); + ok( defined $sth,'Statement handle defined'); + ok( $sth->execute,'execute'); + for ( 3, 7 ) + { + my $row = $sth->fetch; + is( $row->[0], $_ ,"fetch $_"); + is( $row->[1],"T$_","fetch T$_"); + } +} +ok( $dbh->rollback,'Rollback'); +ok( $dbh->disconnect,'Disconnect');
new file mode 100644 --- /dev/null +++ b/DBD/t/DBD_TEST.pm @@ -0,0 +1,87 @@ +# This Source Code Form is subject to the terms of the Mozilla Public +# License, v. 2.0. If a copy of the MPL was not distributed with this +# file, You can obtain one at http://mozilla.org/MPL/2.0/. +# +# Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + +package DBD_TEST; + +=head1 DESCRIPTION + +This package is a common set of routines for the DBD::monetdb tests. + +=cut + +use strict; +use warnings; +use DBI qw(:sql_types); + +our $VERSION = '0.07'; +our $table_name = 'PERL_DBD_TEST'; + +our %TestFieldInfo = ( + 'A' => [SQL_INTEGER, SQL_SMALLINT, SQL_TINYINT, SQL_NUMERIC, SQL_DECIMAL] +,'B' => [SQL_WVARCHAR, SQL_VARCHAR, SQL_WCHAR, SQL_CHAR] +,'C' => [SQL_WLONGVARCHAR, SQL_LONGVARCHAR, SQL_WVARCHAR, SQL_VARCHAR] +,'D' => [SQL_TYPE_DATE, SQL_TYPE_TIMESTAMP, SQL_DATE, SQL_TIMESTAMP] +); + + +sub get_type_for_column { + my $dbh = shift; + my $col = shift; + + $dbh->type_info( $TestFieldInfo{$col} ); +} + + +sub tab_create { + my $dbh = shift; + my $tbl = shift || $table_name; + { + local ($dbh->{PrintError}, $dbh->{RaiseError}, $dbh->{Warn}); + $dbh->{PrintError} = $dbh->{RaiseError} = $dbh->{Warn} = 0; + $dbh->do("DROP TABLE $tbl"); + } + my $fields; + for my $f ( sort keys %TestFieldInfo ) { + my $ti = get_type_for_column( $dbh, $f ); + $fields .= ', ' if $fields; + $fields .= "$f "; + $fields .= $ti->{TYPE_NAME}; + + if ( defined $ti->{CREATE_PARAMS} ) { + my $size = $ti->{COLUMN_SIZE}; + $size = 50 if $f eq 'B'; # TODO + $fields .= "( $size )" if $ti->{CREATE_PARAMS} =~ /LENGTH/i; + $fields .= "( $size, 0 )" if $ti->{CREATE_PARAMS} =~ /PRECISION,SCALE/i; + } + } + print "# Using fields: $fields\n"; + return $dbh->do("CREATE TABLE $tbl( $fields )"); +} + + +sub tab_delete { + my $dbh = shift; + my $tbl = shift || $table_name; + + $dbh->do("DELETE FROM $tbl"); +} + + +sub dump_results { + my $sth = shift; + my $rows = 0; + + return 0 unless $sth; + + while ( my $row = $sth->fetch ) { + $rows++; + print '# ', DBI::neat_list( $row ),"\n"; + } + print "# $rows rows\n"; + $rows; +} + +1;
new file mode 100644 --- /dev/null +++ b/Makefile.ag @@ -0,0 +1,15 @@ +# This Source Code Form is subject to the terms of the Mozilla Public +# License, v. 2.0. If a copy of the MPL was not distributed with this +# file, You can obtain one at http://mozilla.org/MPL/2.0/. +# +# Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + +MTSAFE + +SUBDIRS = MonetDB-CLI-MapiPP MonetDB-CLI DBD Tests + +headers_perl = { + HEADERS = pm + DIR = $(prefix)/$(PERL_LIBDIR) + SOURCES = Mapi.pm +}
new file mode 100644 --- /dev/null +++ b/Mapi.pm @@ -0,0 +1,457 @@ +# This Source Code Form is subject to the terms of the Mozilla Public +# License, v. 2.0. If a copy of the MPL was not distributed with this +# file, You can obtain one at http://mozilla.org/MPL/2.0/. +# +# Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + +package Mapi; + +use strict; +use Socket; +use IO::Socket; +use Digest::MD5 'md5_hex'; +use Digest::SHA qw(sha1_hex sha256_hex sha512_hex); + +sub pass_chal { + my ($passwd, @challenge) = @_; + if ($challenge[2] == 9) { + my $pwhash = $challenge[5]; + if ($pwhash eq 'SHA512') { + $passwd = sha512_hex($passwd); + } elsif ($pwhash eq 'SHA256') { + $passwd = sha256_hex($passwd); + } elsif ($pwhash eq 'SHA1') { + $passwd = sha1_hex($passwd); + } elsif ($pwhash eq 'MD5') { + $passwd = md5_hex($passwd); + } else { + warn "unsupported password hash: ".$pwhash; + return; + } + } else { + warn "unsupported protocol version: ".$challenge[2]; + return; + } + + my @cyphers = split(/,/, $challenge[3]); + my $chal; + foreach (@cyphers) { + if ($_ eq 'SHA512') { + $chal = "{$_}".sha512_hex($passwd.$challenge[0]); + last; + } elsif ($_ eq 'SHA256') { + $chal = "{$_}".sha256_hex($passwd.$challenge[0]); + last; + } elsif ($_ eq 'SHA1') { + $chal = "{$_}".sha1_hex($passwd.$challenge[0]); + last; + } elsif ($_ eq 'MD5') { + $chal = "{$_}".md5_hex($passwd.$challenge[0]); + last; + } + } + if (!$chal) { + warn "unsupported hash algorithm necessary for login: ".$challenge[3]; + return; + } + + return $chal; +} + +sub new { + my $mapi = shift; + my $host = shift || 'localhost'; + my $port = shift || 50000; + my $user = shift || 'monetdb'; + my $passwd = shift || 'monetdb'; + my $lang = shift || 'sql'; + my $db = shift || ''; + my $trace = shift || 0; + my $self = {}; + + bless( $self, $mapi ); + + $self->{trace} = $trace; + + print "new:$host,$port,$user,$passwd,$lang,$db\n" if ($self->{trace}); + $self->{host} = $host; + $self->{port} = $port; + $self->{user} = $user; + $self->{passwd} = $passwd; + $self->{lang} = $lang; + $self->{db} = $db; + $self->{socket} = IO::Socket::INET->new( + PeerAddr => $host, + PeerPort => $port, + Proto => 'tcp' + ) || die "!ERROR can't connect to $host:$port $!"; + $self->{piggyback} = []; + $self->{skip_in} = 0; + + #binmode($self->{socket},":utf8"); + + #block challenge:mserver:9:cypher(s):content_byteorder(BIG/LIT):pwhash\n"); + my $block = $self->getblock(); + my @challenge = split(/:/, $block); + print "Connection to socket established ($block)\n" if ($self->{trace}); + + my $passchal = pass_chal($passwd, @challenge) || die; + + # content_byteorder(BIG/LIT):user:{cypher_algo}mypasswordchallenge_cyphered:lang:database: + $self->putblock("LIT:$user:$passchal:$lang:$db:\n"); + my $prompt = $self->getblock(); + if ($prompt =~ /^\^mapi:monetdb:/) { + # full reconnect + $self->{socket}->close; + print "Following redirect: $prompt\n" if ($self->{trace}); + my @tokens = split(/[\n\/:\?]+/, $prompt); # dirty, but it's Perl anyway + return new Mapi($tokens[3], $tokens[4], $user, $passwd, $lang, $tokens[5], $trace); + } elsif ($prompt =~ /^\^mapi:merovingian:\/\/proxy/) { + # proxied redirect + do { + print "Being proxied by $host:$port\n" if ($self->{trace}); + $block = $self->getblock(); + @challenge = split(/:/, $block); + $passchal = pass_chal($passwd, @challenge) || die; + $self->putblock("LIT:$user:$passchal:$lang:$db:\n"); + $prompt = $self->getblock(); + } while ($prompt =~ /^\^mapi:merovingian:proxy/); + } # TODO: don't die on warnings (#) + die $prompt if ($prompt ne ""); + print "Logged on $user\@$db with $lang\n" if ($self->{trace}); + return $self; +} + +# How to create a duplicate +sub clone { + my ($self,$src)= @_; + bless($self,"Mapi"); + print "cloning\n" if ($self->{trace}); + $self->{host} = $src->{host}; + $self->{port} = $src->{port}; + $self->{user} = $src->{user}; + $self->{passwd} = $src->{passwd}; + $self->{lang} = $src->{lang}; + $self->{db} = $src->{db}; + $self->{socket} = $src->{socket}; + $self->resetState(); +} + +sub mapiport_intern { + my $mapiport = 'localhost:50000'; + $mapiport = $ENV{'MAPIPORT'} if defined($ENV{'MAPIPORT'}); + return $mapiport; +} + +sub hostname { + my ($hostname) = mapiport_intern() =~ /([^:]*)/; + $hostname = 'localhost' if ($hostname eq ''); + return $hostname; +} + +sub portnr { + my ($portnr) = mapiport_intern() =~ /:([^:]*)/; + $portnr = 50000 if ($portnr eq ''); + return $portnr; +} + +sub disconnect { + my ($self) = @_; + print "disconnect\n" if ($self->{trace}); + $self->{socket}->close; + print "Disconnected from server\n" if ($self->{trace}); +} + +sub showState { + my ($self) = @_; + if ($self->{trace}) { + print "mapi.error :".$self->{error}."\n"; + print "mapi.errstr:".$self->{errstr}."\n"; + print "mapi.active:".$self->{active}."\n"; + print "mapi.row[".length($self->{row})."]:".$self->{row}."\n"; + } +} + +sub resetState { + my ($self) = @_; + print "resetState\n" if ($self->{trace}); + $self->{errstr}=""; + $self->{error}=0; + $self->{active}=0; +} + +#packge the request and ship it, the back-end reads blocks! +sub doRequest { + my($self,$cmd) = @_; + + $cmd = "S" . $cmd if $self->{lang} eq 'sql'; + # even if the query ends with a ;, this never hurts and fixes the -- on last line bug + $cmd = $cmd . "\n;\n"; + print "doRequest:$cmd\n" if ($self->{trace}); + $self->putblock($cmd); # TODO handle exceptions || die "!ERROR can't send $cmd: $!"; + $self->resetState(); +} + +# Analyse a single line for errors +sub error { + my ($self,$line) = @_; + my $err = $self->{errstr}; + $err = "$err\n" if (length($err) > 0); + $line =~ s/^\!//; + $self->{errstr} = $err . $line; +# $self->showState(); + $self->{row}= ""; + $self->{error} = 1; + print "Error found $self->{error}\n" if ($self->{trace}); +} + +# analyse commentary lines for auxiliary information +sub propertyTest { + my ($self) =@_; + my $err= $self->{error}; + my $row= $self->{row}; +# $self->showState(); + if ($row =~ /^\#---/) { + $self->{row}= ""; + return 1; + } + if ($row =~ /^\#.*\#/) { + $self->{row}= ""; + return 1; + } + return 0; +} + + +sub getRow { + my ($self)= @_; + my $row = $self->{lines}[$self->{next}++]; + my @chars = split(//, $row,3); + + if ($chars[0] eq '!') { + $self->error($row); + my $i = 1; + while ($self->{lines}[$i] =~ '!') { + $self->error($self->{lines}[$i]); + $i++; + } + $self->{active} = 0; + return -1 + } elsif ($chars[0] eq '&') { + # not expected + } elsif ($chars[0] eq '%') { + # header line + } elsif ($chars[0] eq '[') { + # row result + $self->{row} = $row; + if ($self->{nrcols} < 0) { + $self->{nrcols} = () = $row =~ /,\t/g; + $self->{nrcols}++; + } + $self->{active} = 1; + } elsif ($chars[0] eq '=') { + # xml result line + $self->{row} = substr($row, 1); # skip = + $self->{active} = 1; + } elsif ($chars[0] eq '^') { + # ^ redirect, ie use different server + } elsif ($chars[0] eq '#') { + # warnings etc, skip, and return what follows + return $self->getRow; + } + return $self->{active}; +} + +sub getBlock { + my ($self)= @_; + print "getBlock $self->{active}\n" if ($self->{trace}); + my $block = $self->getblock(); + @{$self->{lines}} = split(/\n/, $block); + + # skip diagnostic messages before the header + shift @{$self->{lines}} while @{$self->{lines}} && $self->{lines}[0] =~ /\A#/; + + die "implausible return from MonetDB: $self->{lines}[0]\n" if $self->{lines}[0] =~ /\A[^ -~]/; + + my $header = $self->{lines}[0]; + my @chars = split(//, $header); + + $self->{id} = -1; + $self->{nrcols} = -1; + $self->{replysize} = scalar(@{$self->{lines}}); + $self->{active} = 0; + $self->{skip} = 0; # next+skip is current result row + $self->{next} = 0; # all done + $self->{offset} = 0; + $self->{hdrs} = []; + + if ($chars[0] eq '&') { + if ($chars[1] eq '1' || $chars[1] eq 6) { + if ($chars[1] eq '1') { + # &1 id result-count nr-cols rows-in-this-block + my ($dummy,$id,$cnt,$nrcols,$replysize) = split(' ', $header); + $self->{id} = $id; + $self->{count} = $cnt; + $self->{nrcols} = $nrcols; + $self->{replysize} = $replysize; + } else { + # &6 id nr-cols,rows-in-this-block,offset + my ($dummy,$id,$nrcols,$replysize,$offset) = split(' ', $header); + $self->{id} = $id; + $self->{nrcols} = $nrcols; + $self->{replysize} = $replysize; + $self->{offset} = $offset; + } + # for now skip table header information + my $i = 1; + while ($self->{lines}[$i] =~ /\A%/) { + $self->{hdrs}[$i - 1] = $self->{lines}[$i]; + $i++; + } + $self->{skip} = $i; + $self->{next} = $i; + $self->{row} = $self->{lines}[$self->{next}++]; + + $self->{active} = 1; + } elsif ($chars[1] eq '2') { # updates + my ($dummy,$cnt) = split(' ', $header); + $self->{count} = $cnt; + $self->{nrcols} = 1; + $self->{replysize} = 1; + $self->{row} = "" . $cnt; + $self->{next} = $cnt; # all done + return -2; + } elsif ($chars[1] eq '3') { # transaction + # nothing todo + } elsif ($chars[1] eq '4') { # auto_commit + my ($dummy,$ac) = split(' ', $header); + if ($ac eq 't') { + $self->{auto_commit} = 1; + } else { + $self->{auto_commit} = 0; + } + } elsif ($chars[1] eq '5') { # prepare + my ($dummy,$id,$cnt,$nrcols,$replysize) = split(' ', $header); + # TODO parse result, rows (type, digits, scale) + $self->{count} = $cnt; + $self->{nrcols} = $nrcols; + $self->{replysize} = $replysize; + $self->{row} = ""; + $self->{next} = $cnt; # all done + } + } else { + return $self->getRow(); + } + return $self->{active}; +} + +sub getReply { + my ($self)= @_; + + if ($self->{active} == 0) { + return $self->getBlock(); + } elsif ($self->{next} < $self->{replysize} + $self->{skip}) { + return $self->getRow(); + } elsif (${self}->{offset} + $self->{replysize} < $self->{count}) { + # get next slice + my $rs = $self->{replysize}; + my $offset = $self->{offset} + $rs; + $self->putblock("Xexport $self->{id} $offset $rs"); + return $self->getBlock(); + } else { + # close large results, but only send on next query + if ($self->{id} > 0 && $self->{count} != $self->{replysize}) { + push @{$self->{piggyback}}, "Xclose $self->{id}"; + $self->{skip_in}++; + } + $self->{active} = 0; + } + return $self->{active}; + +} + +sub readFromSocket { + my ($self, $ref, $count) = @_; + + die "invalid buffer reference" unless (ref($ref) eq 'SCALAR'); + + my $rcount = 0; + $$ref ||= ""; + + while ($count > 0) { + $rcount = $self->{socket}->sysread($$ref, $count, length($$ref)); + + die "read error: $!" unless (defined($rcount)); + die "no more data on socket" if ($rcount == 0); + + $count -= $rcount; + } +} + +sub getblock { + my ($self) = @_; + + # now read back the same way + my $result = ""; + my $last_block = 0; + do { + my $flag; + + $self->readFromSocket(\$flag, 2); # read block info + + my $unpacked = unpack( 'v', $flag ); # unpack (little endian short) + my $len = ( $unpacked >> 1 ); # get length + $last_block = $unpacked & 1; # get last-block-flag + + print "getblock: $last_block $len\n" if ($self->{trace}); + if ($len > 0 ) { + my $data; + $self->readFromSocket(\$data, $len); # read + $result .= $data; + print "getblock: $data\n" if ($self->{trace}); + } + } while ( !$last_block ); + print "IN:\n$result\n" if $ENV{MAPI_TRACE}; + + if ($self->{skip_in}) { + $self->{skip_in}--; + goto &getblock; + } + + return $result; +} + +sub putblock { + my $self = shift; + + # there maybe something in the piggyback buffer + my @blocks = (\(@{ $self->{piggyback} }), \(@_)); + @{ $self->{piggyback} } = (); + + # create blocks of data with max 0xffff length, + # then loop over the data and send it. + my $out = ''; + for my $blk (@blocks) { + print "OUT:\n$$blk\n" if $ENV{MAPI_TRACE}; + utf8::downgrade($$blk); # deny wide chars + my $pos = 0; + my $last_block = 0; + my $blocksize = 0x7fff >> 1; # max len per block + my $data; + + while ( !$last_block ) { + my $data = substr($$blk, 0, $blocksize, ""); + my $len = length($data); + # set last-block-flag + $last_block = 1 if !length $$blk; + my $flag = pack( 'v', ( $len << 1 ) + $last_block ); + print "putblock: $last_block ".$data."\n" if ($self->{trace}); + $out .= $flag . $data; + } + } + $self->{socket}->syswrite($out); #send it +} + +1; + +# vim: set ts=2 sw=2 expandtab:
new file mode 100644 --- /dev/null +++ b/MonetDB-CLI-MapiPP/Makefile.ag @@ -0,0 +1,7 @@ +# This Source Code Form is subject to the terms of the Mozilla Public +# License, v. 2.0. If a copy of the MPL was not distributed with this +# file, You can obtain one at http://mozilla.org/MPL/2.0/. +# +# Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + +SUBDIRS = MonetDB
new file mode 100644 --- /dev/null +++ b/MonetDB-CLI-MapiPP/MonetDB/CLI/MANIFEST @@ -0,0 +1,9 @@ +Changes +MANIFEST +MANIFEST.SKIP +Makefile.PL +README +MapiPP.pm +t/00use.t +t/02cxn.t +t/75mil.t
new file mode 100644 --- /dev/null +++ b/MonetDB-CLI-MapiPP/MonetDB/CLI/MANIFEST.SKIP @@ -0,0 +1,6 @@ +^Makefile$ +^Makefile\.ag$ +^Makefile\.old$ +^pm_to_blib$ +\.properties$ +^blib/
new file mode 100644 --- /dev/null +++ b/MonetDB-CLI-MapiPP/MonetDB/CLI/Makefile.PL @@ -0,0 +1,9 @@ +use ExtUtils::MakeMaker; + +WriteMakefile +( + NAME => 'MonetDB::CLI::MapiPP' +, VERSION_FROM => 'MapiPP.pm' +, ABSTRACT_FROM => 'MapiPP.pm' +, PREREQ_PM => { 'IO::Socket::INET' => 0 } +);
new file mode 100644 --- /dev/null +++ b/MonetDB-CLI-MapiPP/MonetDB/CLI/Makefile.ag @@ -0,0 +1,13 @@ +# This Source Code Form is subject to the terms of the Mozilla Public +# License, v. 2.0. If a copy of the MPL was not distributed with this +# file, You can obtain one at http://mozilla.org/MPL/2.0/. +# +# Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + +MTSAFE + +headers_perl = { + HEADERS = pm + DIR = $(prefix)/$(PERL_LIBDIR)/MonetDB/CLI + SOURCES = MapiPP.pm +}
new file mode 100644 --- /dev/null +++ b/MonetDB-CLI-MapiPP/MonetDB/CLI/MapiPP.pm @@ -0,0 +1,268 @@ +package MonetDB::CLI::MapiPP; + +use Text::ParseWords(); +use Encode (); +use Mapi; +use strict; +use warnings; + +our $VERSION = '0.04'; + + +my %unescape = ( n => "\n", t => "\t", r => "\r", f => "\f"); + +sub unquote +{ + if (!defined($_) || $_ eq 'NULL' || $_ eq 'nil') { $_ = undef; return; } + + if ( /^["']/) { + s/^["']//; + s/["']$//; + s/\\([0-7]{3}|.)/length($1) == 3 ? chr(oct($1)) : ($unescape{$1} || $1)/eg; + } +} + +sub connect +{ + my ($class, $host, $port, $user, $pass, $lang, $db) = @_; + + my $h = new Mapi($host, $port, $user, $pass, $lang, $db, 0) + or die "Making connection failed: $@"; + + bless { h => $h },'MonetDB::CLI::MapiPP::Cxn'; +} + + +package MonetDB::CLI::MapiPP::Cxn; + +sub query +{ + my ($self, $statement) = @_; + + my $h = $self->new_handle; + $h->query($statement); + + return $h; +} + +sub new_handle +{ + my ($self) = @_; + + bless { h => $self->{h} },'MonetDB::CLI::MapiPP::Req'; +} + +sub DESTROY +{ + my ($self) = @_; + + $self->{h}->disconnect(); + + return; +} + + +package MonetDB::CLI::MapiPP::Req; + +sub query +{ + my ($self, $statement) = @_; + + my $h = $self->{h}; + $h->doRequest($statement); + + $self->{i} = -1; + $self->{rows} = []; + $self->{querytype} = -1; + $self->{id} = -1; + $self->{affrows} = -1; + $self->{colcnt} = -1; + $self->{colnames} = []; + $self->{coltypes} = []; + $self->{collens} = []; + + my $tpe = $h->getReply(); + if ($tpe > 0) { + # "regular" resultset, or just "tuple" + $self->{querytype} = 1; + $self->{id} = $h->{id} || -1; + $self->{affrows} = $h->{count} if $h->{count}; + $self->{colcnt} = $h->{nrcols} if $h->{nrcols}; + + my $hdr; + foreach $hdr (@{$h->{hdrs}}) { + my $nme = substr($hdr, rindex($hdr, "# ")); + $hdr = substr($hdr, 2, -(length($nme) + 1)); + if ($nme eq "# name") { + @{$self->{colnames}} = split(/,\t/, $hdr); + } elsif ($nme eq "# type") { + @{$self->{coltypes}} = split(/,\t/, $hdr); + } elsif ($nme eq "# length") { + @{$self->{collens}} = split(/,\t/, $hdr); + } + # TODO: table_name + } + # we must pre-fetch if this is not an SQL result-set + if (!defined $h->{count}) { + do { + utf8::decode($self->{h}->{row}); + my @cols = split(/,\t */, $h->{row}); + my $i = -1; + for (@cols) { + s/^\[ //; + s/[ \t]+\]$//; + MonetDB::CLI::MapiPP::unquote(); + } + push(@{$self->{rows}}, [@cols]); + } while (($tpe = $h->getReply()) > 0); + $self->{affrows} = @{$self->{rows}}; + undef $self->{id}; + } + } elsif ($tpe == -1) { + # error + die $h->{errstr}; + } elsif ($tpe == -2) { + # update count/affected rows + $self->{affrows} = $h->{count}; + } +} + +sub querytype +{ + my ($self) = @_; + + return $self->{querytype}; +} + +sub id +{ + my ($self) = @_; + + return $self->{id} || -1; +} + +sub rows_affected +{ + my ($self) = @_; + + return $self->{affrows}; +} + +sub columncount +{ + my ($self) = @_; + + return $self->{colcnt}; +} + +sub name +{ + my ($self, $fnr) = @_; + + return $self->{colnames}[$fnr] || ''; +} + +sub type +{ + my ($self, $fnr) = @_; + + return $self->{coltypes}[$fnr] || ''; +} + +sub length +{ + my ($self, $fnr) = @_; + + return $self->{collens}[$fnr] || 0; +} + +sub fetch +{ + my ($self) = @_; + + return if ++$self->{i} >= $self->{affrows}; + + if ($self->{id}) { + utf8::decode($self->{h}->{row}); + my @cols = split(/,\t */, $self->{h}->{row}); + my $i = -1; + $cols[0] =~ s/^\[ //; + $cols[-1] =~ s/[ \t]+\]$//; + for (@cols) { + MonetDB::CLI::MapiPP::unquote(); + } + $self->{currow} = [@cols]; + $self->{h}->getReply(); + } else { + $self->{currow} = $self->{rows}[$self->{i}]; + } + + return @{$self->{currow}}; +} + +sub field +{ + my ($self, $fnr) = @_; + + return $self->{currow}[$fnr]; +} + +sub finish +{ + my ($self) = @_; + + $self->{$_} = -1 for qw(querytype id tuplecount columncount i); + $self->{$_} = "" for qw(query); + $self->{$_} = [] for qw(rows name type length); + + return; +} + +sub DESTROY +{ + my ($self) = @_; + + return; +} + +__PACKAGE__; + +=head1 NAME + +MonetDB::CLI::MapiPP - MonetDB::CLI implementation, using the Mapi protocol + +=head1 DESCRIPTION + +MonetDB::CLI::MapiPP is an implementation of the MonetDB call level interface +L<MonetDB::CLI>. +It's a Pure Perl module. +It uses the Mapi protocol - a text based communication layer on top of TCP. +Normally, you don't use this module directly, but let L<MonetDB::CLI> +choose an implementation module. + +=head1 AUTHORS + +Steffen Goeldner E<lt>sgoeldner@cpan.orgE<gt>. +Fabian Groffen E<lt>fabian@cwi.nlE<gt>. + +=head1 COPYRIGHT AND LICENCE + +This Source Code Form is subject to the terms of the Mozilla Public +License, v. 2.0. If a copy of the MPL was not distributed with this +file, You can obtain one at http://mozilla.org/MPL/2.0/. + +Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + +=head1 SEE ALSO + +=head2 MonetDB + + Homepage : http://www.monetdb.org/ + +=head2 Perl modules + +L<MonetDB::CLI> + +=cut + +# vim: set ts=2 sw=2 expandtab:
new file mode 100644 --- /dev/null +++ b/MonetDB-CLI-MapiPP/MonetDB/CLI/README @@ -0,0 +1,70 @@ +NAME + + MonetDB::CLI::MapiPP - MonetDB::CLI implementation, using the Mapi protocol + +SYNOPSIS + + use MonetDB::CLI::MapiPP; + + my $cxn = MonetDB::CLI::MapiPP->connect( $host, $port, $user, $pass, $lang ); + + my $req = $cxn->query('select * from env() env'); + while ( my $cnt = $req->fetch ) { + print $req->field( $_ ) for 0 .. $cnt-1; + } + +DESCRIPTION + + MonetDB::CLI::MapiPP is an implementation of the MonetDB call level interface + MonetDB::CLI. + It's a Pure Perl module. + It uses the Mapi protocol - a text based communication layer on top of TCP. + Normally, you don't use this module directly, but let MonetDB::CLI + choose an implementation module. + +PREREQUISITES + + IO::Socket::INET + + MonetDB (http://www.monetdb.org/) + +INSTALLATION + + To install this module type the following: + + perl Makefile.PL + make + make test + make install + + You need to use the correct make command. That may be nmake or dmake, + depending on which development environment you are using. + +TESTING + + The supplied tests will connect to the database using some + environment variables, e.g.: + + set MONETDB_HOST=myhost + set MONETDB_PORT=4711 + + Don't specify port and language (if possible). The server should + listen on the default ports for sql and mapi. + + If the server doesn't accept the default username/password, then + set the relevant environment variables, e.g.: + + set MONETDB_USER=test + set MONETDB_PASS=secret + +AUTHORS + + Steffen Goeldner <sgoeldner@cpan.org>. + +COPYRIGHT AND LICENCE + + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at http://mozilla.org/MPL/2.0/. + + Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V.
new file mode 100644 --- /dev/null +++ b/MonetDB-CLI-MapiPP/MonetDB/CLI/t/00use.t @@ -0,0 +1,12 @@ +# This Source Code Form is subject to the terms of the Mozilla Public +# License, v. 2.0. If a copy of the MPL was not distributed with this +# file, You can obtain one at http://mozilla.org/MPL/2.0/. +# +# Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + +use Test::More tests => 2; + +BEGIN { + use_ok( MonetDB::CLI::MapiPP ); +} +require_ok( MonetDB::CLI::MapiPP );
new file mode 100644 --- /dev/null +++ b/MonetDB-CLI-MapiPP/MonetDB/CLI/t/02cxn.t @@ -0,0 +1,63 @@ +# This Source Code Form is subject to the terms of the Mozilla Public +# License, v. 2.0. If a copy of the MPL was not distributed with this +# file, You can obtain one at http://mozilla.org/MPL/2.0/. +# +# Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + +$| = 1; + +use strict; +use warnings; + +use Test::More tests => 18; + +use MonetDB::CLI::MapiPP; + +pass('Connection tests'); + +my $host = $ENV{MONETDB_HOST} || 'localhost'; +my $port = $ENV{MONETDB_PORT} || 50000; +my $user = $ENV{MONETDB_USER} || 'monetdb'; +my $pass = $ENV{MONETDB_PASS} || 'monetdb'; +my $lang = 'sql'; + +my $cxn = eval { + MonetDB::CLI::MapiPP->connect( $host, $port, $user, $pass, $lang ) +}; +ok(!$@,'connect') or print "# $@"; +ok( $cxn,"Connection object: $cxn"); + +my $req = eval { $cxn->query('select * from env() env') }; +ok(!$@,'query') or print "# $@"; +ok( $req,"Request object: $req"); + +my $cnt = eval { $req->columncount }; +is( $cnt, 2,"columncount: $cnt"); + +my $querytype = eval { $req->querytype }; +is( $querytype, 1,"querytype: $querytype"); + +for my $k ('id','rows_affected') { + my $v = eval { $req->$k }; + ok( defined $v,"$k: $v"); +} +for my $k ('name','type','length') { + for my $i ( 0, 1 ) { + my $v = eval { $req->$k( $i ) }; + ok( $v,"$k( $i ): $v"); + } +} +my $rows = 0; +while ( my $cnt = eval { $req->fetch } ) { + print '#'; + print "\t", $req->field( $_ ) for 0 .. $cnt-1; + print "\n"; + $rows++; +} +is( $rows, $req->rows_affected,"rows: $rows"); + +{ + my $req = eval { $cxn->query('select * from non_existent_table') }; + ok( $@,"Error expected: $@"); + ok(!$req,'No request object'); +}
new file mode 100644 --- /dev/null +++ b/MonetDB-CLI-MapiPP/MonetDB/CLI/t/75mil.t @@ -0,0 +1,63 @@ +# This Source Code Form is subject to the terms of the Mozilla Public +# License, v. 2.0. If a copy of the MPL was not distributed with this +# file, You can obtain one at http://mozilla.org/MPL/2.0/. +# +# Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + +$| = 1; + +use strict; +use warnings; + +use Test::More tests => 18; + +use MonetDB::CLI::MapiPP; + +pass('Connection tests'); + +my $host = $ENV{MONETDB_HOST} || 'localhost'; +my $port = $ENV{MONETDB_PORT} || 50000; +my $user = $ENV{MONETDB_USER} || 'monetdb'; +my $pass = $ENV{MONETDB_PASS} || 'monetdb'; +my $lang = 'mil'; + +my $cxn = eval { + MonetDB::CLI::MapiPP->connect( $host, $port, $user, $pass, $lang ) +}; +ok(!$@,'connect') or print "# $@"; +ok( $cxn,"Connection object: $cxn"); + +my $req = eval { $cxn->query('env();') }; +ok(!$@,'query') or print "# $@"; +ok( $req,"Request object: $req"); + +my $cnt = eval { $req->columncount }; +is( $cnt, 2,"columncount: $cnt"); + +my $querytype = eval { $req->querytype }; +is( $querytype, -1,"querytype: $querytype"); + +for my $k ('id','rows_affected') { + my $v = eval { $req->$k }; + ok( $v,"$k: $v"); +} +for my $k ('name','type','length') { + for my $i ( 0, 1 ) { + my $v = eval { $req->$k( $i ) }; + ok( defined $v,"$k( $i ): $v"); + } +} +my $rows = 0; +while ( my $cnt = eval { $req->fetch } ) { + print '#'; + print "\t", $req->field( $_ ) for 0 .. $cnt-1; + print "\n"; + $rows++; +} +is( $rows, $req->rows_affected,"rows: $rows"); + +{ + my $req = eval { $cxn->query('( xyz 1);') }; + ok( $@,"Error expected: $@"); + ok(!$req,'No request object'); +}
new file mode 100644 --- /dev/null +++ b/MonetDB-CLI-MapiPP/MonetDB/Makefile.ag @@ -0,0 +1,7 @@ +# This Source Code Form is subject to the terms of the Mozilla Public +# License, v. 2.0. If a copy of the MPL was not distributed with this +# file, You can obtain one at http://mozilla.org/MPL/2.0/. +# +# Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + +SUBDIRS = CLI
new file mode 100644 --- /dev/null +++ b/MonetDB-CLI/Makefile.ag @@ -0,0 +1,7 @@ +# This Source Code Form is subject to the terms of the Mozilla Public +# License, v. 2.0. If a copy of the MPL was not distributed with this +# file, You can obtain one at http://mozilla.org/MPL/2.0/. +# +# Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + +SUBDIRS = MonetDB
new file mode 100644 --- /dev/null +++ b/MonetDB-CLI/MonetDB/CLI.pm @@ -0,0 +1,106 @@ +package MonetDB::CLI; + +our $VERSION = '0.03'; + +our @Modules = split /;/, $ENV{PERL_MONETDB_CLI_MODULES} + || 'MonetDB::CLI::MapiPP'; + +sub connect +{ + my $class = shift; + + eval "require( $_ )" and return $_->connect( @_ ) for @Modules; + + chomp $@; die "No MonetDB::CLI implementation found: $@"; +} + +__PACKAGE__; + +=head1 NAME + +MonetDB::CLI - MonetDB Call Level Interface + +=head1 SYNOPSIS + + use MonetDB::CLI(); + + my $cxn = MonetDB::CLI->connect( $host, $port, $user, $pass, $lang, $db ); + + my $req = $cxn->query('select * from env() env'); + while ( my $cnt = $req->fetch ) { + print $req->field( $_ ) for 0 .. $cnt-1; + } + +=head1 DESCRIPTION + +MonetDB::CLI is a call level interface for MonetDB, somewhat similar +to SQL/CLI, ODBC, JDBC or DBI. + +B<Note:> In its current incarnation, this interface resembles the MonetDB +Application Programming Interface. +In the future, MAPI will be replaced by the MonetDB/Five Communication Layer +(MCL). +It is not guaranteed that this call level interface stays the same! + +=head2 The C<connect()> method + + my $cxn = MonetDB::CLI->connect( $host, $port, $user, $pass, $lang, $db ); + +This method tries to load an implementation module from C<@Modules> and +delegates to the C<connect()> method of the first successful loaded module. +Otherwise, an exception is raised. + +The default list of implementation modules can be changed with the +C<PERL_MONETDB_CLI_MODULES> environment variable. +A semicolon-separated list of module names is expected. + +=head2 Connection object methods + +It's up to the implementation modules to provide the methods for the +connection object: + + my $req = $cxn->query( $statement ); # request object + +=head2 Request object methods + +It's up to the implementation modules to provide the methods for the +request object: + + print $req->querytype; + print $req->id; + print $req->rows_affected; + print $req->columncount; + + for ( 0 .. $req->columncount - 1 ) { + print $req->name ( $_ ); + print $req->type ( $_ ); + print $req->length( $_ ); + } + while ( my $cnt = $req->fetch ) { + print $req->field( $_ ) for 0 .. $cnt-1; + } + +=head1 AUTHORS + +Steffen Goeldner E<lt>sgoeldner@cpan.orgE<gt>. + +=head1 COPYRIGHT AND LICENCE + +This Source Code Form is subject to the terms of the Mozilla Public +License, v. 2.0. If a copy of the MPL was not distributed with this +file, You can obtain one at http://mozilla.org/MPL/2.0/. + +Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + + +=head1 SEE ALSO + +=head2 MonetDB + + Homepage : http://www.monetdb.org/ + +=head2 Perl modules + +L<MonetDB::CLI::MapiLib>, L<MonetDB::CLI::MapiXS>, L<MonetDB::CLI::MapiPP> + +=cut
new file mode 100644 --- /dev/null +++ b/MonetDB-CLI/MonetDB/MANIFEST @@ -0,0 +1,9 @@ +Changes +MANIFEST +MANIFEST.SKIP +Makefile.PL +README +CLI.pm +t/00use.t +t/02cxn.t +t/75mil.t
new file mode 100644 --- /dev/null +++ b/MonetDB-CLI/MonetDB/MANIFEST.SKIP @@ -0,0 +1,6 @@ +^Makefile$ +^Makefile\.ag$ +^Makefile\.old$ +^pm_to_blib$ +\.properties$ +^blib/
new file mode 100644 --- /dev/null +++ b/MonetDB-CLI/MonetDB/Makefile.PL @@ -0,0 +1,9 @@ +use ExtUtils::MakeMaker; + +WriteMakefile +( + NAME => 'MonetDB::CLI' +, VERSION_FROM => 'CLI.pm' +, ABSTRACT_FROM => 'CLI.pm' +, PREREQ_PM => { 'MonetDB::CLI::MapiPP' => 0.01 } +);
new file mode 100644 --- /dev/null +++ b/MonetDB-CLI/MonetDB/Makefile.ag @@ -0,0 +1,13 @@ +# This Source Code Form is subject to the terms of the Mozilla Public +# License, v. 2.0. If a copy of the MPL was not distributed with this +# file, You can obtain one at http://mozilla.org/MPL/2.0/. +# +# Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + +MTSAFE + +headers_perl = { + HEADERS = pm + DIR = $(prefix)/$(PERL_LIBDIR)/MonetDB + SOURCES = CLI.pm +}
new file mode 100644 --- /dev/null +++ b/MonetDB-CLI/MonetDB/README @@ -0,0 +1,75 @@ +NAME + + MonetDB::CLI - MonetDB Call Level Interface + +SYNOPSIS + + use MonetDB::CLI(); + + my $cxn = MonetDB::CLI->connect( $host, $port, $user, $pass, $lang ); + + my $req = $cxn->query('select * from env() env'); + while ( my $cnt = $req->fetch ) { + print $req->field( $_ ) for 0 .. $cnt-1; + } + +DESCRIPTION + + MonetDB::CLI is a call level interface for MonetDB, somewhat similar + to SQL/CLI, ODBC, JDBC or DBI. + + Note: In its current incarnation, this interface resembles the MonetDB + Application Programming Interface. + In the future, MAPI will be replaced by the MonetDB/Five Communication Layer + (MCL). + It is not guaranteed that this call level interface stays the same! + +PREREQUISITES + + MonetDB::CLI::* (implementation modules) + + MonetDB (http://www.monetdb.org/) + +INSTALLATION + + To install this module type the following: + + perl Makefile.PL + make + make test + make install + + You need to use the correct make command. That may be nmake or dmake, + depending on which development environment you are using. + +TESTING + + The supplied tests will connect to the database using some + environment variables, e.g.: + + set MONETDB_HOST=myhost + set MONETDB_PORT=4711 + + Don't specify port and language (if possible). The server should + listen on the default ports for sql and mapi. + + If the server doesn't accept the default username/password, then + set the relevant environment variables, e.g.: + + set MONETDB_USER=test + set MONETDB_PASS=secret + + Make sure libMapi is in your library search path (depending on the + MonetDB::CLI implementations in use). + +AUTHORS + + Steffen Goeldner <sgoeldner@cpan.org>. + +COPYRIGHT AND LICENCE + + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at http://mozilla.org/MPL/2.0/. + + Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V.
new file mode 100644 --- /dev/null +++ b/MonetDB-CLI/MonetDB/t/00use.t @@ -0,0 +1,12 @@ +# This Source Code Form is subject to the terms of the Mozilla Public +# License, v. 2.0. If a copy of the MPL was not distributed with this +# file, You can obtain one at http://mozilla.org/MPL/2.0/. +# +# Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + +use Test::More tests => 2; + +BEGIN { + use_ok( MonetDB::CLI ); +} +require_ok( MonetDB::CLI );
new file mode 100644 --- /dev/null +++ b/MonetDB-CLI/MonetDB/t/02cxn.t @@ -0,0 +1,63 @@ +# This Source Code Form is subject to the terms of the Mozilla Public +# License, v. 2.0. If a copy of the MPL was not distributed with this +# file, You can obtain one at http://mozilla.org/MPL/2.0/. +# +# Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + +$| = 1; + +use strict; +use warnings; + +use Test::More tests => 18; + +use MonetDB::CLI; + +pass('Connection tests'); + +my $host = $ENV{MONETDB_HOST} || 'localhost'; +my $port = $ENV{MONETDB_PORT} || 50000; +my $user = $ENV{MONETDB_USER} || 'monetdb'; +my $pass = $ENV{MONETDB_PASS} || 'monetdb'; +my $lang = 'sql'; + +my $cxn = eval { + MonetDB::CLI->connect( $host, $port, $user, $pass, $lang ) +}; +ok(!$@,'connect') or print "# $@"; +ok( $cxn,"Connection object: $cxn"); + +my $req = eval { $cxn->query('select * from env') }; +ok(!$@,'query') or print "# $@"; +ok( $req,"Request object: $req"); + +my $cnt = eval { $req->columncount }; +is( $cnt, 2,"columncount: $cnt"); + +my $querytype = eval { $req->querytype }; +is( $querytype, 3,"querytype: $querytype"); + +for my $k ('id','rows_affected') { + my $v = eval { $req->$k }; + ok( $v,"$k: $v"); +} +for my $k ('name','type','length') { + for my $i ( 0, 1 ) { + my $v = eval { $req->$k( $i ) }; + ok( $v,"$k( $i ): $v"); + } +} +my $rows = 0; +while ( my $cnt = eval { $req->fetch } ) { + print '#'; + print "\t", $req->field( $_ ) for 0 .. $cnt-1; + print "\n"; + $rows++; +} +is( $rows, $req->rows_affected,"rows: $rows"); + +{ + my $req = eval { $cxn->query('select * from non_existent_table') }; + ok( $@,"Error expected: $@"); + ok(!$req,'No request object'); +}
new file mode 100644 --- /dev/null +++ b/MonetDB-CLI/MonetDB/t/75mil.t @@ -0,0 +1,63 @@ +# This Source Code Form is subject to the terms of the Mozilla Public +# License, v. 2.0. If a copy of the MPL was not distributed with this +# file, You can obtain one at http://mozilla.org/MPL/2.0/. +# +# Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + +$| = 1; + +use strict; +use warnings; + +use Test::More tests => 18; + +use MonetDB::CLI; + +pass('Connection tests'); + +my $host = $ENV{MONETDB_HOST} || 'localhost'; +my $port = $ENV{MONETDB_PORT} || 50000; +my $user = $ENV{MONETDB_USER} || 'monetdb'; +my $pass = $ENV{MONETDB_PASS} || 'monetdb'; +my $lang = 'mil'; + +my $cxn = eval { + MonetDB::CLI->connect( $host, $port, $user, $pass, $lang ) +}; +ok(!$@,'connect') or print "# $@"; +ok( $cxn,"Connection object: $cxn"); + +my $req = eval { $cxn->query('env();') }; +ok(!$@,'query') or print "# $@"; +ok( $req,"Request object: $req"); + +my $cnt = eval { $req->columncount }; +is( $cnt, 2,"columncount: $cnt"); + +my $querytype = eval { $req->querytype }; +is( $querytype, -1,"querytype: $querytype"); + +for my $k ('id','rows_affected') { + my $v = eval { $req->$k }; + ok( $v,"$k: $v"); +} +for my $k ('name','type','length') { + for my $i ( 0, 1 ) { + my $v = eval { $req->$k( $i ) }; + ok( defined $v,"$k( $i ): $v"); + } +} +my $rows = 0; +while ( my $cnt = eval { $req->fetch } ) { + print '#'; + print "\t", $req->field( $_ ) for 0 .. $cnt-1; + print "\n"; + $rows++; +} +is( $rows, $req->rows_affected,"rows: $rows"); + +{ + my $req = eval { $cxn->query('( xyz 1);') }; + ok( $@,"Error expected: $@"); + ok(!$req,'No request object'); +}
new file mode 100755 --- /dev/null +++ b/mclient.pl @@ -0,0 +1,37 @@ +#!/usr/bin/env perl + +# This Source Code Form is subject to the terms of the Mozilla Public +# License, v. 2.0. If a copy of the MPL was not distributed with this +# file, You can obtain one at http://mozilla.org/MPL/2.0/. +# +# Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V. + +use Mapi; + +my $db = shift || ''; +my $port = shift || 50000; + +my ($monet, $line); +$monet = new Mapi('localhost', $port, 'monetdb', 'monetdb', 'sql', $db, 0); + +print "> "; +while ( !(($line=<>) =~ /\q/) ){ + my $res = 0; + $monet->doRequest($line); + while( ($res = $monet->getReply()) > 0 ) { + print $monet->{row} . "\n"; + } + if ($res < 0) { + if ($res == -1) { + print $monet->{errstr}; + } elsif ($res == -2) { + print "$monet->{count} rows affected\n"; + } + } + print "> "; +} + +$monet->disconnect(); + +1; +