Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 470 lines (386 sloc) 12.769 kb
5abdea8 Dave Olszewski Update FakeDBD::Pg to MiniDBD::Pg
cxreg authored
1 # MiniDBD::Pg.pm6
b4fd1dc Dave Olszewski Add support for Postgresql
cxreg authored
2
3 use NativeCall; # from project 'zavolaj'
5abdea8 Dave Olszewski Update FakeDBD::Pg to MiniDBD::Pg
cxreg authored
4 use MiniDBD; # roles for drivers
b4fd1dc Dave Olszewski Add support for Postgresql
cxreg authored
5
5abdea8 Dave Olszewski Update FakeDBD::Pg to MiniDBD::Pg
cxreg authored
6 #module MiniDBD:auth<mberends>:ver<0.0.1>;
b4fd1dc Dave Olszewski 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 Lenz [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 Dave Olszewski Add support for Postgresql
cxreg authored
33 sub PQresultStatus (OpaquePointer $result)
34 returns Int
35 is native('libpq')
36 { ... }
37
7e8555e Dave Olszewski fetch PQerrorMessage after connect failure
cxreg authored
38 sub PQerrorMessage (OpaquePointer $conn)
39 returns Str
40 is native('libpq')
41 { ... }
42
299edb0 Dave Olszewski refactoring and adding missing DBI methods
cxreg authored
43 sub PQresultErrorMessage (OpaquePointer $result)
b4fd1dc Dave Olszewski 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 Dave Olszewski PQcmdTuples returns a string, not an int.
cxreg authored
69 returns Str
b4fd1dc Dave Olszewski 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 Lenz several stylistic updates, like proper constants
moritz authored
88 constant CONNECTION_OK = 0;
89 constant CONNECTION_BAD = 1;
b4fd1dc Dave Olszewski Add support for Postgresql
cxreg authored
90
f1da178 Moritz Lenz 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 Dave Olszewski Add support for Postgresql
cxreg authored
96
97 #-----------------------------------------------------------------------
98
5abdea8 Dave Olszewski Update FakeDBD::Pg to MiniDBD::Pg
cxreg authored
99 class MiniDBD::Pg::StatementHandle does MiniDBD::StatementHandle {
b4fd1dc Dave Olszewski Add support for Postgresql
cxreg authored
100 has $!pg_conn;
f1da178 Moritz Lenz several stylistic updates, like proper constants
moritz authored
101 has $.RaiseError;
5b2a675 Moritz Lenz create proper prepared statements (but do not use them yet)
moritz authored
102 has Str $!statement_name;
b4fd1dc Dave Olszewski Add support for Postgresql
cxreg authored
103 has $!statement;
f1da178 Moritz Lenz several stylistic updates, like proper constants
moritz authored
104 has $.dbh;
b4fd1dc Dave Olszewski Add support for Postgresql
cxreg authored
105 has $!result;
106 has $!affected_rows;
107 has @!column_names;
a1ad66b Moritz Lenz fix some Pg initialization
moritz authored
108 has Int $!row_count;
b4fd1dc Dave Olszewski Add support for Postgresql
cxreg authored
109 has $!field_count;
110 has $!current_row;
7e8555e Dave Olszewski fetch PQerrorMessage after connect failure
cxreg authored
111
d2afbfe Moritz Lenz [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 Lenz 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 Lenz [Pg] factor out error handling
moritz authored
139 self!handle-errors;
140 True;
5b2a675 Moritz Lenz create proper prepared statements (but do not use them yet)
moritz authored
141 }
b4fd1dc Dave Olszewski Add support for Postgresql
cxreg authored
142 method execute(*@params is copy) {
143 $!current_row = 0;
703b375 Moritz Lenz [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 Dave Olszewski Add support for Postgresql
cxreg authored
147 }
703b375 Moritz Lenz [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 Lenz [Pg] factor out error handling
moritz authored
156 self!handle-errors;
a1ad66b Moritz Lenz fix some Pg initialization
moritz authored
157 $!row_count = PQntuples($!result);
299edb0 Dave Olszewski refactoring and adding missing DBI methods
cxreg authored
158
159 my $rows = self.rows;
160 return ($rows == 0) ?? "0E0" !! $rows;
b4fd1dc Dave Olszewski 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 Lenz [Pg] factor out error handling
moritz authored
169 self!handle-errors;
b4fd1dc Dave Olszewski Add support for Postgresql
cxreg authored
170 }
171
172 if defined $!affected_rows {
b50230b Dave Olszewski PQcmdTuples returns a string, not an int.
cxreg authored
173 return +$!affected_rows;
b4fd1dc Dave Olszewski 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 Lenz fix Pg enough to run through all the tests
moritz authored
186 self!errstr = Any;
b4fd1dc Dave Olszewski 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 Lenz [Pg] factor out error handling
moritz authored
192 self!handle-errors;
b4fd1dc Dave Olszewski 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 Lenz fix Pg enough to run through all the tests
moritz authored
208 self!set_errstr(Any);
b4fd1dc Dave Olszewski Add support for Postgresql
cxreg authored
209
299edb0 Dave Olszewski refactoring and adding missing DBI methods
cxreg authored
210 my @row = self!get_row();
211
212 my $errstr = PQresultErrorMessage ($!result);
b4fd1dc Dave Olszewski Add support for Postgresql
cxreg authored
213 if $errstr ne '' {
73428f2 Moritz Lenz make MiniDBD::Pg compile
moritz authored
214 self!errstr = $errstr;
215 if $!RaiseError { die $errstr; }
b4fd1dc Dave Olszewski Add support for Postgresql
cxreg authored
216 return;
217 }
218
299edb0 Dave Olszewski refactoring and adding missing DBI methods
cxreg authored
219 if @row {
220 $row_arrayref = @row;
b4fd1dc Dave Olszewski 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 Lenz fix Pg enough to run through all the tests
moritz authored
235 self!set_errstr(Any);
b4fd1dc Dave Olszewski Add support for Postgresql
cxreg authored
236 my @all_array;
237 for ^$!row_count {
299edb0 Dave Olszewski refactoring and adding missing DBI methods
cxreg authored
238 my @row = self!get_row();
b4fd1dc Dave Olszewski Add support for Postgresql
cxreg authored
239
299edb0 Dave Olszewski refactoring and adding missing DBI methods
cxreg authored
240 my $errstr = PQresultErrorMessage ($!result);
b4fd1dc Dave Olszewski Add support for Postgresql
cxreg authored
241 if $errstr ne '' {
73428f2 Moritz Lenz make MiniDBD::Pg compile
moritz authored
242 self!errstr = $errstr;
243 if $!RaiseError { die $errstr; }
b4fd1dc Dave Olszewski Add support for Postgresql
cxreg authored
244 return;
245 }
246
299edb0 Dave Olszewski refactoring and adding missing DBI methods
cxreg authored
247 if @row {
248 my $row_arrayref = @row;
b4fd1dc Dave Olszewski 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 Lenz fix Pg enough to run through all the tests
moritz authored
269 self!set_errstr(Any);
299edb0 Dave Olszewski refactoring and adding missing DBI methods
cxreg authored
270 my $errstr = PQresultErrorMessage ($!result);
b4fd1dc Dave Olszewski Add support for Postgresql
cxreg authored
271 if $errstr ne '' {
73428f2 Moritz Lenz make MiniDBD::Pg compile
moritz authored
272 self!errstr = $errstr;
273 if $!RaiseError { die $errstr; }
b4fd1dc Dave Olszewski Add support for Postgresql
cxreg authored
274 return;
275 }
276
299edb0 Dave Olszewski refactoring and adding missing DBI methods
cxreg authored
277 my @row = self!get_row();
b4fd1dc Dave Olszewski 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 Dave Olszewski refactoring and adding missing DBI methods
cxreg authored
286 if @row && @!column_names {
287 for @row Z @!column_names -> $column_value, $column_name {
b4fd1dc Dave Olszewski 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 Dave Olszewski 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 Dave Olszewski Add support for Postgresql
cxreg authored
312 method finish() {
313 if defined($!result) {
314 PQclear($!result);
b9da926 Moritz Lenz fix Pg enough to run through all the tests
moritz authored
315 $!result = Any;
316 @!column_names = ();
b4fd1dc Dave Olszewski Add support for Postgresql
cxreg authored
317 }
318 return Bool::True;
319 }
299edb0 Dave Olszewski 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 Dave Olszewski Add support for Postgresql
cxreg authored
330 }
331
5abdea8 Dave Olszewski Update FakeDBD::Pg to MiniDBD::Pg
cxreg authored
332 class MiniDBD::Pg::Connection does MiniDBD::Connection {
b4fd1dc Dave Olszewski Add support for Postgresql
cxreg authored
333 has $!pg_conn;
a1ad66b Moritz Lenz fix some Pg initialization
moritz authored
334 has $.RaiseError;
299edb0 Dave Olszewski refactoring and adding missing DBI methods
cxreg authored
335 has $.AutoCommit is rw = 1;
336 has $.in_transaction is rw;
a1ad66b Moritz Lenz fix some Pg initialization
moritz authored
337 method BUILD(:$!pg_conn) { }
299edb0 Dave Olszewski refactoring and adding missing DBI methods
cxreg authored
338
339 method prepare(Str $statement, $attr?) {
5abdea8 Dave Olszewski Update FakeDBD::Pg to MiniDBD::Pg
cxreg authored
340 my $statement_handle = MiniDBD::Pg::StatementHandle.bless(
341 MiniDBD::Pg::StatementHandle.CREATE(),
b9da926 Moritz Lenz fix Pg enough to run through all the tests
moritz authored
342 :$!pg_conn,
343 :$statement,
344 :$!RaiseError,
0660dff Moritz Lenz Stylistic change
moritz authored
345 :dbh(self),
b4fd1dc Dave Olszewski Add support for Postgresql
cxreg authored
346 );
347 return $statement_handle;
348 }
299edb0 Dave Olszewski 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 Lenz [Pg] implement ping
moritz authored
411
412 method ping {
413 PQstatus($!pg_conn) == CONNECTION_OK
414 }
b4fd1dc Dave Olszewski Add support for Postgresql
cxreg authored
415 }
416
5abdea8 Dave Olszewski Update FakeDBD::Pg to MiniDBD::Pg
cxreg authored
417 class MiniDBD::Pg:auth<mberends>:ver<0.0.1> {
b4fd1dc Dave Olszewski Add support for Postgresql
cxreg authored
418
419 has $.Version = 0.01;
e900311 Dave Olszewski Add $!errstr to MiniDBD::Pg
cxreg authored
420 has $!errstr;
73428f2 Moritz Lenz make MiniDBD::Pg compile
moritz authored
421 method !errstr() is rw { $!errstr }
b4fd1dc Dave Olszewski Add support for Postgresql
cxreg authored
422
5abdea8 Dave Olszewski Update FakeDBD::Pg to MiniDBD::Pg
cxreg authored
423 #------------------ methods to be called from MiniDBI ------------------
2f56347 Moritz Lenz switch Pg to named params too
moritz authored
424 method connect(*%params) {
b4fd1dc Dave Olszewski Add support for Postgresql
cxreg authored
425 my $host = %params<host> // 'localhost';
299edb0 Dave Olszewski refactoring and adding missing DBI methods
cxreg authored
426 my $port = %params<port> // 5432;
2f56347 Moritz Lenz 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 Dave Olszewski 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 Lenz 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 Lenz switch Pg to named params too
moritz authored
437 :RaiseError(%params<RaiseError>),
b4fd1dc Dave Olszewski Add support for Postgresql
cxreg authored
438 );
439 }
7e8555e Dave Olszewski fetch PQerrorMessage after connect failure
cxreg authored
440 else {
441 $!errstr = PQerrorMessage($pg_conn);
2f56347 Moritz Lenz switch Pg to named params too
moritz authored
442 if %params<RaiseError> { die $!errstr; }
7e8555e Dave Olszewski fetch PQerrorMessage after connect failure
cxreg authored
443 }
b4fd1dc Dave Olszewski Add support for Postgresql
cxreg authored
444 return $connection;
445 }
446 }
447
448 =begin pod
449
450 =head1 DESCRIPTION
5abdea8 Dave Olszewski 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 Dave Olszewski 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 Dave Olszewski 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 Dave Olszewski Add support for Postgresql
cxreg authored
457
458 =head1 CLASSES
5abdea8 Dave Olszewski Update FakeDBD::Pg to MiniDBD::Pg
cxreg authored
459 The MiniDBD::Pg module contains the same classes and methods as every
b4fd1dc Dave Olszewski Add support for Postgresql
cxreg authored
460 database driver. Therefore read the main documentation of usage in
5abdea8 Dave Olszewski 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 Dave Olszewski 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.