File Coverage

blib/lib/ClearPress/driver/mysql.pm
Criterion Covered Total %
statement 18 56 32.1
branch 0 16 0.0
condition 0 18 0.0
subroutine 6 12 50.0
pod 6 6 100.0
total 30 108 27.7


line stmt bran cond sub pod time code
1             # -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*-
2             # vim:ts=8:sw=2:et:sta:sts=2
3             #########
4             # Author: rmp
5             # Created: 2006-10-31
6             #
7             package ClearPress::driver::mysql;
8 13     13   90 use strict;
  13         30  
  13         555  
9 13     13   83 use warnings;
  13         29  
  13         427  
10 13     13   82 use base qw(ClearPress::driver);
  13         33  
  13         1301  
11 13     13   92 use English qw(-no_match_vars);
  13         38  
  13         79  
12 13     13   5110 use Carp;
  13         35  
  13         770  
13 13     13   5254 use Readonly;
  13         53907  
  13         9239  
14              
15             our $VERSION = q[477.1.4];
16              
17             Readonly::Scalar our $TYPES => {
18             'primary key' => 'bigint unsigned not null auto_increment primary key',
19             };
20             sub dbh {
21 0     0 1   my $self = shift;
22              
23 0 0 0       if($self->{dbh} && !$self->{dbh}->ping()) {
24 0           $self->{dbh}->disconnect();
25 0           delete $self->{dbh};
26             }
27              
28 0 0         if(!$self->{dbh}) {
29 0           my $dsn_opts = q[];
30 0 0         if($self->{dsn_opts}) {
31 0 0 0       if(ref $self->{dsn_opts} && scalar keys %{$self->{dsn_opts}}) {
  0            
32             #########
33             # structured key:value pairs
34             #
35 0           $dsn_opts = join q[;], q[], map { sprintf q[%s=%s], $_, $self->{dsn_opts}->{$_} } sort keys %{$self->{dsn_opts}};
  0            
  0            
36              
37             } else {
38             #########
39             # scalar line e.g. straight out of config.ini
40             #
41 0           $dsn_opts = sprintf q[;%s], $self->{dsn_opts};
42             }
43             }
44              
45             my $dsn = sprintf q(DBI:mysql:database=%s;host=%s;port=%s%s),
46             $self->{dbname} || q[],
47             $self->{dbhost} || q[localhost],
48 0   0       $self->{dbport} || q[3306],
      0        
      0        
49             $dsn_opts;
50              
51             eval {
52             $self->{dbh} = DBI->connect($dsn,
53             $self->{dbuser} || q[],
54             $self->{dbpass},
55             {
56 0   0       RaiseError => 1,
57             AutoCommit => 0,
58             mysql_enable_utf8 => 1,
59             });
60              
61             # 2010-05-12 post-connect SET NAMES utf8 demonstrated to work a lot better than connect with mysql_enable_utf8 => 1
62             #
63             # Using test data: update run set payload='{"comment":"abc øéü"}' where id_run=2;
64             #
65             # this works on OSX MacPorts MySQL 5.1 but not on CentOS 5.4 MySQL 5.0
66             # perl -MDBI -e 'my $dbh = DBI->connect("DBI:mysql:host=localhost;dbname=ontrackt", "root", "", {RaiseError=>1});$dbh->do(q[update run set payload=? where id_run=2],{},q[abc øéµ]);print $dbh->selectall_arrayref(q[SELECT payload FROM run WHERE id_run=2])->[0]->[0],"\n";'
67             #
68             # this works on OSX and CentOS:
69             # perl -MDBI -e 'my $dbh = DBI->connect("DBI:mysql:host=localhost;dbname=ontrackt", "root", "", {RaiseError=>1});$dbh->do(q[SET NAMES utf8]);$dbh->do(q[update run set payload=? where id_run=2],{},q[abc øéµ]);print $dbh->selectall_arrayref(q[SELECT payload FROM run WHERE id_run=2])->[0]->[0],"\n";'
70             #
71             # this works on neither OSX nor CentOS
72             # perl -MDBI -e 'my $dbh = DBI->connect("DBI:mysql:host=localhost;dbname=ontrackt", "root", "", {RaiseError=>1,mysql_enable_utf8 =>1});$dbh->do(q[update run set payload=? where id_run=2],{},q[abc øéµ]);print $dbh->selectall_arrayref(q[SELECT payload FROM run WHERE id_run=2])->[0]->[0],"\n";'
73              
74 0           $self->{dbh}->do(q[SET NAMES utf8]);
75              
76 0 0         } or do {
77 0   0       croak qq[Failed to connect to $dsn using @{[$self->{dbuser}||q['']]}\n$EVAL_ERROR];
  0            
78             };
79              
80             #########
81             # rollback any junk left behind if this is a cached handle
82             #
83 0           $self->{dbh}->rollback();
84             }
85              
86 0           return $self->{dbh};
87             }
88              
89             sub create {
90 0     0 1   my ($self, $query, @args) = @_;
91 0           my $dbh = $self->dbh();
92              
93 0           $dbh->do($query, {}, @args);
94 0           my $idref = $dbh->selectall_arrayref('SELECT LAST_INSERT_ID()');
95              
96 0           return $idref->[0]->[0];
97             }
98              
99             sub create_table {
100 0     0 1   my ($self, $table_name, $ref) = @_;
101 0           return $self->SUPER::create_table($table_name, $ref, { engine=>'InnoDB'});
102             }
103              
104             sub types {
105 0     0 1   return $TYPES;
106             }
107              
108             sub bounded_select {
109 0     0 1   my ($self, $query, $len, $start) = @_;
110              
111 0 0 0       if(defined $start && defined $len) {
    0          
112 0           $query .= qq[ LIMIT $start, $len];
113             } elsif(defined $len) {
114 0           $query .= qq[ LIMIT $len];
115             }
116              
117 0           return $query;
118             }
119              
120             sub sth_has_warnings {
121 0     0 1   my ($self, $sth) = @_;
122              
123 0 0         if($sth->{mysql_warning_count}) {
124 0           return $self->{dbh}->selectall_arrayref(q[SHOW WARNINGS]);
125             }
126              
127 0           return;
128             }
129              
130              
131             1;
132             __END__