Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 470 lines (386 sloc) 12.769 kB
5abdea8 @cxreg Update FakeDBD::Pg to MiniDBD::Pg
cxreg authored
1 # MiniDBD::Pg.pm6
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
2
3 use NativeCall; # from project 'zavolaj'
5abdea8 @cxreg Update FakeDBD::Pg to MiniDBD::Pg
cxreg authored
4 use MiniDBD; # roles for drivers
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
5
5abdea8 @cxreg Update FakeDBD::Pg to MiniDBD::Pg
cxreg authored
6 #module MiniDBD:auth<mberends>:ver<0.0.1>;
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
7
8 #------------ Pg library functions in alphabetical order ------------
9
10 sub PQexec (OpaquePointer $conn, Str $statement)
11 returns OpaquePointer
12 is native('libpq')
13 { ... }
14
824b42a @moritz [Pg] stub in a few functions needed for prepared statements
moritz authored
15 sub PQprepare (OpaquePointer $conn, Str $statement_name, Str $query, Int $n_params, OpaquePointer $paramTypes)
16 returns OpaquePointer
17 is native('libpq')
18 { ... }
19
20 sub PQexecPrepared(
21 OpaquePointer $conn,
22 Str $statement_name,
23 Int $n_params,
24 CArray[Str] $param_values,
25 CArray[int] $param_length,
26 CArray[int] $param_formats,
27 Int $resultFormat
28 )
29 returns OpaquePointer
30 is native('libpq')
31 { ... }
32
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
33 sub PQresultStatus (OpaquePointer $result)
34 returns Int
35 is native('libpq')
36 { ... }
37
7e8555e @cxreg fetch PQerrorMessage after connect failure
cxreg authored
38 sub PQerrorMessage (OpaquePointer $conn)
39 returns Str
40 is native('libpq')
41 { ... }
42
299edb0 @cxreg refactoring and adding missing DBI methods
cxreg authored
43 sub PQresultErrorMessage (OpaquePointer $result)
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
44 returns Str
45 is native('libpq')
46 { ... }
47
48 sub PQconnectdb (Str $conninfo)
49 returns OpaquePointer
50 is native('libpq')
51 { ... }
52
53 sub PQstatus (OpaquePointer $conn)
54 returns Int
55 is native('libpq')
56 { ... }
57
58 sub PQnfields (OpaquePointer $result)
59 returns Int
60 is native('libpq')
61 { ... }
62
63 sub PQntuples (OpaquePointer $result)
64 returns Int
65 is native('libpq')
66 { ... }
67
68 sub PQcmdTuples (OpaquePointer $result)
b50230b @cxreg PQcmdTuples returns a string, not an int.
cxreg authored
69 returns Str
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
70 is native('libpq')
71 { ... }
72
73 sub PQgetvalue (OpaquePointer $result, Int $row, Int $col)
74 returns Str
75 is native('libpq')
76 { ... }
77
78 sub PQfname (OpaquePointer $result, Int $col)
79 returns Str
80 is native('libpq')
81 { ... }
82
83 sub PQclear (OpaquePointer $result)
84 is native('libpq')
85 { ... }
86
87
f1da178 @moritz several stylistic updates, like proper constants
moritz authored
88 constant CONNECTION_OK = 0;
89 constant CONNECTION_BAD = 1;
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
90
f1da178 @moritz several stylistic updates, like proper constants
moritz authored
91 constant PGRES_EMPTY_QUERY = 0;
92 constant PGRES_COMMAND_OK = 1;
93 constant PGRES_TUPLES_OK = 2;
94 constant PGRES_COPY_OUT = 3;
95 constant PGRES_COPY_IN = 4;
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
96
97 #-----------------------------------------------------------------------
98
5abdea8 @cxreg Update FakeDBD::Pg to MiniDBD::Pg
cxreg authored
99 class MiniDBD::Pg::StatementHandle does MiniDBD::StatementHandle {
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
100 has $!pg_conn;
f1da178 @moritz several stylistic updates, like proper constants
moritz authored
101 has $.RaiseError;
5b2a675 @moritz create proper prepared statements (but do not use them yet)
moritz authored
102 has Str $!statement_name;
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
103 has $!statement;
f1da178 @moritz several stylistic updates, like proper constants
moritz authored
104 has $.dbh;
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
105 has $!result;
106 has $!affected_rows;
107 has @!column_names;
a1ad66b @moritz fix some Pg initialization
moritz authored
108 has Int $!row_count;
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
109 has $!field_count;
110 has $!current_row;
7e8555e @cxreg fetch PQerrorMessage after connect failure
cxreg authored
111
d2afbfe @moritz [Pg] factor out error handling
moritz authored
112 method !handle-errors {
113 my $status = PQresultStatus($!result);
114 if $status != PGRES_EMPTY_QUERY | PGRES_COMMAND_OK | PGRES_TUPLES_OK | PGRES_COPY_OUT | PGRES_COPY_IN {
115 self!set_errstr(PQresultErrorMessage($!result));
116 if $!RaiseError { die self!errstr; }
117 }
118 self!set_errstr(Any);
119 }
120
5b2a675 @moritz create proper prepared statements (but do not use them yet)
moritz authored
121 method !munge_statement {
122 my $count = 0;
123 my $munged = $!statement.subst(:g, '?', { '$' ~ ++$count});
124 return ($munged, $count);
125 }
126
127 submethod BUILD(:$!statement, :$!pg_conn) {
128 state $statement_postfix = 0;
129 $!statement_name = join '_', 'pg', $*PID, $statement_postfix++;
130 my ($munged, $nparams) = self!munge_statement;
131
132 $!result = PQprepare(
133 $!pg_conn,
134 $!statement_name,
135 $munged,
136 $nparams,
137 OpaquePointer
138 );
d2afbfe @moritz [Pg] factor out error handling
moritz authored
139 self!handle-errors;
140 True;
5b2a675 @moritz create proper prepared statements (but do not use them yet)
moritz authored
141 }
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
142 method execute(*@params is copy) {
143 $!current_row = 0;
703b375 @moritz [Pg] use prepared statements in execute
moritz authored
144 my @param_values := CArray[Str].new;
145 for @params.kv -> $k, $v {
146 @param_values[$k] = $v.Str;
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
147 }
703b375 @moritz [Pg] use prepared statements in execute
moritz authored
148
149 $!result = PQexecPrepared($!pg_conn, $!statement_name, @params.elems,
150 @param_values,
151 OpaquePointer, # ParamLengths, NULL pointer == all text
152 OpaquePointer, # ParamFormats, NULL pointer == all text
153 0, # Resultformat, 0 == text
154 );
155
d2afbfe @moritz [Pg] factor out error handling
moritz authored
156 self!handle-errors;
a1ad66b @moritz fix some Pg initialization
moritz authored
157 $!row_count = PQntuples($!result);
299edb0 @cxreg refactoring and adding missing DBI methods
cxreg authored
158
159 my $rows = self.rows;
160 return ($rows == 0) ?? "0E0" !! $rows;
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
161 }
162
163 # do() and execute() return the number of affected rows directly or:
164 # rows() is called on the statement handle $sth.
165 method rows() {
166 unless defined $!affected_rows {
167 $!affected_rows = PQcmdTuples($!result);
168
d2afbfe @moritz [Pg] factor out error handling
moritz authored
169 self!handle-errors;
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
170 }
171
172 if defined $!affected_rows {
b50230b @cxreg PQcmdTuples returns a string, not an int.
cxreg authored
173 return +$!affected_rows;
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
174 }
175 }
176
177 method fetchrow_array() {
178 my @row_array;
179 return if $!current_row >= $!row_count;
180
181 unless defined $!field_count {
182 $!field_count = PQnfields($!result);
183 }
184
185 if defined $!result {
b9da926 @moritz fix Pg enough to run through all the tests
moritz authored
186 self!errstr = Any;
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
187
188 for ^$!field_count {
189 @row_array.push(PQgetvalue($!result, $!current_row, $_));
190 }
191 $!current_row++;
d2afbfe @moritz [Pg] factor out error handling
moritz authored
192 self!handle-errors;
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
193
194 if ! @row_array { self.finish; }
195 }
196 return @row_array;
197 }
198
199 method fetchrow_arrayref() {
200 my $row_arrayref;
201
202 return if $!current_row >= $!row_count;
203
204 unless defined $!field_count {
205 $!field_count = PQnfields($!result);
206 }
207 if defined $!result {
b9da926 @moritz fix Pg enough to run through all the tests
moritz authored
208 self!set_errstr(Any);
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
209
299edb0 @cxreg refactoring and adding missing DBI methods
cxreg authored
210 my @row = self!get_row();
211
212 my $errstr = PQresultErrorMessage ($!result);
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
213 if $errstr ne '' {
73428f2 @moritz make MiniDBD::Pg compile
moritz authored
214 self!errstr = $errstr;
215 if $!RaiseError { die $errstr; }
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
216 return;
217 }
218
299edb0 @cxreg refactoring and adding missing DBI methods
cxreg authored
219 if @row {
220 $row_arrayref = @row;
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
221 }
222 else { self.finish; }
223 }
224 return $row_arrayref;
225 }
226 method fetch() { self.fetchrow_arrayref(); } # alias according to perldoc DBI
227 method fetchall_arrayref() {
228 my $all_arrayref;
229 return if $!current_row >= $!row_count;
230
231 unless defined $!field_count {
232 $!field_count = PQnfields($!result);
233 }
234 if defined $!result {
b9da926 @moritz fix Pg enough to run through all the tests
moritz authored
235 self!set_errstr(Any);
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
236 my @all_array;
237 for ^$!row_count {
299edb0 @cxreg refactoring and adding missing DBI methods
cxreg authored
238 my @row = self!get_row();
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
239
299edb0 @cxreg refactoring and adding missing DBI methods
cxreg authored
240 my $errstr = PQresultErrorMessage ($!result);
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
241 if $errstr ne '' {
73428f2 @moritz make MiniDBD::Pg compile
moritz authored
242 self!errstr = $errstr;
243 if $!RaiseError { die $errstr; }
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
244 return;
245 }
246
299edb0 @cxreg refactoring and adding missing DBI methods
cxreg authored
247 if @row {
248 my $row_arrayref = @row;
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
249 push @all_array, $row_arrayref;
250 }
251 else { self.finish; }
252 }
253 $all_arrayref = @all_array;
254 }
255 return $all_arrayref;
256 }
257
258 method fetchrow_hashref () {
259 my $row_hashref;
260 my %row_hash;
261
262 return if $!current_row >= $!row_count;
263
264 unless defined $!field_count {
265 $!field_count = PQnfields($!result);
266 }
267
268 if defined $!result {
b9da926 @moritz fix Pg enough to run through all the tests
moritz authored
269 self!set_errstr(Any);
299edb0 @cxreg refactoring and adding missing DBI methods
cxreg authored
270 my $errstr = PQresultErrorMessage ($!result);
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
271 if $errstr ne '' {
73428f2 @moritz make MiniDBD::Pg compile
moritz authored
272 self!errstr = $errstr;
273 if $!RaiseError { die $errstr; }
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
274 return;
275 }
276
299edb0 @cxreg refactoring and adding missing DBI methods
cxreg authored
277 my @row = self!get_row();
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
278
279 unless @!column_names {
280 for ^$!field_count {
281 my $column_name = PQfname($!result, $_);
282 @!column_names.push($column_name);
283 }
284 }
285
299edb0 @cxreg refactoring and adding missing DBI methods
cxreg authored
286 if @row && @!column_names {
287 for @row Z @!column_names -> $column_value, $column_name {
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
288 %row_hash{$column_name} = $column_value;
289 }
290 } else {
291 self.finish;
292 }
293
294 $row_hashref = %row_hash;
295 }
296 return $row_hashref;
297 }
298
299edb0 @cxreg refactoring and adding missing DBI methods
cxreg authored
299 method fetchall_hashref(Str $key) {
300 my %results;
301
302 return if $!current_row >= $!row_count;
303
304 while my $row = self.fetchrow_hashref {
305 %results{$row{$key}} = $row;
306 }
307
308 my $results_ref = %results;
309 return $results_ref;
310 }
311
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
312 method finish() {
313 if defined($!result) {
314 PQclear($!result);
b9da926 @moritz fix Pg enough to run through all the tests
moritz authored
315 $!result = Any;
316 @!column_names = ();
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
317 }
318 return Bool::True;
319 }
299edb0 @cxreg refactoring and adding missing DBI methods
cxreg authored
320
321 method !get_row {
322 my @data;
323 for ^$!field_count {
324 @data.push(PQgetvalue($!result, $!current_row, $_));
325 }
326 $!current_row++;
327
328 return @data;
329 }
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
330 }
331
5abdea8 @cxreg Update FakeDBD::Pg to MiniDBD::Pg
cxreg authored
332 class MiniDBD::Pg::Connection does MiniDBD::Connection {
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
333 has $!pg_conn;
a1ad66b @moritz fix some Pg initialization
moritz authored
334 has $.RaiseError;
299edb0 @cxreg refactoring and adding missing DBI methods
cxreg authored
335 has $.AutoCommit is rw = 1;
336 has $.in_transaction is rw;
a1ad66b @moritz fix some Pg initialization
moritz authored
337 method BUILD(:$!pg_conn) { }
299edb0 @cxreg refactoring and adding missing DBI methods
cxreg authored
338
339 method prepare(Str $statement, $attr?) {
5abdea8 @cxreg Update FakeDBD::Pg to MiniDBD::Pg
cxreg authored
340 my $statement_handle = MiniDBD::Pg::StatementHandle.bless(
341 MiniDBD::Pg::StatementHandle.CREATE(),
b9da926 @moritz fix Pg enough to run through all the tests
moritz authored
342 :$!pg_conn,
343 :$statement,
344 :$!RaiseError,
0660dff @moritz Stylistic change
moritz authored
345 :dbh(self),
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
346 );
347 return $statement_handle;
348 }
299edb0 @cxreg refactoring and adding missing DBI methods
cxreg authored
349
350 method do(Str $statement, $attr?, *@bind is copy) {
351 my $sth = self.prepare($statement);
352 $sth.execute(@bind);
353 my $rows = $sth.rows;
354 return ($rows == 0) ?? "0E0" !! $rows;
355 }
356
357 method selectrow_arrayref(Str $statement, $attr?, *@bind is copy) {
358 my $sth = self.prepare($statement, $attr);
359 $sth.execute(@bind);
360 return $sth.fetchrow_arrayref;
361 }
362
363 method selectrow_hashref(Str $statement, $attr?, *@bind is copy) {
364 my $sth = self.prepare($statement, $attr);
365 $sth.execute(@bind);
366 return $sth.fetchrow_hashref;
367 }
368
369 method selectall_arrayref(Str $statement, $attr?, *@bind is copy) {
370 my $sth = self.prepare($statement, $attr);
371 $sth.execute(@bind);
372 return $sth.fetchall_arrayref;
373 }
374
375 method selectall_hashref(Str $statement, Str $key, $attr?, *@bind is copy) {
376 my $sth = self.prepare($statement, $attr);
377 $sth.execute(@bind);
378 return $sth.fetchall_hashref($key);
379 }
380
381 method selectcol_arrayref(Str $statement, $attr?, *@bind is copy) {
382 my @results;
383
384 my $sth = self.prepare($statement, $attr);
385 $sth.execute(@bind);
386 while (my $row = $sth.fetchrow_arrayref) {
387 @results.push($row[0]);
388 }
389
390 my $aref = @results;
391 return $aref;
392 }
393
394 method commit {
395 if $!AutoCommit {
396 warn "Commit ineffective while AutoCommit is on";
397 return;
398 };
399 PQexec($!pg_conn, "COMMIT");
400 $.in_transaction = 0;
401 }
402
403 method rollback {
404 if $!AutoCommit {
405 warn "Rollback ineffective while AutoCommit is on";
406 return;
407 };
408 PQexec($!pg_conn, "ROLLBACK");
409 $.in_transaction = 0;
410 }
20cfae1 @moritz [Pg] implement ping
moritz authored
411
412 method ping {
413 PQstatus($!pg_conn) == CONNECTION_OK
414 }
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
415 }
416
5abdea8 @cxreg Update FakeDBD::Pg to MiniDBD::Pg
cxreg authored
417 class MiniDBD::Pg:auth<mberends>:ver<0.0.1> {
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
418
419 has $.Version = 0.01;
e900311 @cxreg Add $!errstr to MiniDBD::Pg
cxreg authored
420 has $!errstr;
73428f2 @moritz make MiniDBD::Pg compile
moritz authored
421 method !errstr() is rw { $!errstr }
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
422
5abdea8 @cxreg Update FakeDBD::Pg to MiniDBD::Pg
cxreg authored
423 #------------------ methods to be called from MiniDBI ------------------
2f56347 @moritz switch Pg to named params too
moritz authored
424 method connect(*%params) {
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
425 my $host = %params<host> // 'localhost';
299edb0 @cxreg refactoring and adding missing DBI methods
cxreg authored
426 my $port = %params<port> // 5432;
2f56347 @moritz switch Pg to named params too
moritz authored
427 my $database = %params<dbname> // %params<database> // 'postgres';
428 my $user = %params<user> // die 'Missing <user> config';
429 my $password = %params<password> // die 'Missing <password> config';
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
430 my $conninfo = "host=$host port=$port dbname=$database user=$user password=$password";
431 my $pg_conn = PQconnectdb($conninfo);
432 my $status = PQstatus($pg_conn);
433 my $connection;
f1da178 @moritz several stylistic updates, like proper constants
moritz authored
434 if $status eq CONNECTION_OK {
435 $connection = MiniDBD::Pg::Connection.bless(*,
436 :$pg_conn,
2f56347 @moritz switch Pg to named params too
moritz authored
437 :RaiseError(%params<RaiseError>),
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
438 );
439 }
7e8555e @cxreg fetch PQerrorMessage after connect failure
cxreg authored
440 else {
441 $!errstr = PQerrorMessage($pg_conn);
2f56347 @moritz switch Pg to named params too
moritz authored
442 if %params<RaiseError> { die $!errstr; }
7e8555e @cxreg fetch PQerrorMessage after connect failure
cxreg authored
443 }
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
444 return $connection;
445 }
446 }
447
448 =begin pod
449
450 =head1 DESCRIPTION
5abdea8 @cxreg Update FakeDBD::Pg to MiniDBD::Pg
cxreg authored
451 # 'zavolaj' is a Native Call Interface for Rakudo/Parrot. 'MiniDBI' and
452 # 'MiniDBD::Pg' are Perl 6 modules that use 'zavolaj' to use the
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
453 # standard libpq library. There is a long term Parrot based
454 # project to develop a new, comprehensive DBI architecture for Parrot
5abdea8 @cxreg Update FakeDBD::Pg to MiniDBD::Pg
cxreg authored
455 # and Perl 6. MiniDBI is not that, it is a naive rewrite of the
456 # similarly named Perl 5 modules. Hence the 'Mini' part of the name.
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
457
458 =head1 CLASSES
5abdea8 @cxreg Update FakeDBD::Pg to MiniDBD::Pg
cxreg authored
459 The MiniDBD::Pg module contains the same classes and methods as every
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
460 database driver. Therefore read the main documentation of usage in
5abdea8 @cxreg Update FakeDBD::Pg to MiniDBD::Pg
cxreg authored
461 L<doc:MiniDBI> and internal architecture in L<doc:MiniDBD>. Below are
462 only notes about code unique to the MiniDBD::Pg implementation.
b4fd1dc @cxreg Add support for Postgresql
cxreg authored
463
464 =head1 SEE ALSO
465 The Postgres 8.4 Documentation, C Library.
466 L<http://www.postgresql.org/docs/8.4/static/libpq.html>
467
468 =end pod
469
Something went wrong with that request. Please try again.