← Back to branch summary

~percona-toolkit-dev/percona-toolkit/release-2.2.2

« back to all changes in this revision

Viewing changes to lib/DSNParser.pm

  • Committer: Daniel Nichter
  • Date: 2011-06-24 17:22:06 UTC
  • Revision ID: daniel@percona.com-20110624172206-c7q4s4ad6r260zz6
Add lib/, t/lib/, and sandbox/.  All modules are updated and passing on MySQL 5.1.

Show diffs side-by-side

added added

removed removed

Lines of Context:
lib/DSNParser.pm
 
1
# This program is copyright 2011 Percona Inc.
 
2
# This program is copyright 2007-2010 Baron Schwartz.
 
3
# Feedback and improvements are welcome.
 
4
#
 
5
# THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
 
6
# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
 
7
# MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
 
8
#
 
9
# This program is free software; you can redistribute it and/or modify it under
 
10
# the terms of the GNU General Public License as published by the Free Software
 
11
# Foundation, version 2; OR the Perl Artistic License.  On UNIX and similar
 
12
# systems, you can issue `man perlgpl' or `man perlartistic' to read these
 
13
# licenses.
 
14
#
 
15
# You should have received a copy of the GNU General Public License along with
 
16
# this program; if not, write to the Free Software Foundation, Inc., 59 Temple
 
17
# Place, Suite 330, Boston, MA  02111-1307  USA.
 
18
# ###########################################################################
 
19
# DSNParser package $Revision: 7388 $
 
20
# ###########################################################################
 
21
 
 
22
# Package: DSNParser
 
23
# DSNParser parses DSNs and creates connections to MySQL using DBI and
 
24
# DBD::mysql.
 
25
{
 
26
package DSNParser;
 
27
 
 
28
use strict;
 
29
use warnings FATAL => 'all';
 
30
use English qw(-no_match_vars);
 
31
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
 
32
 
 
33
use Data::Dumper;
 
34
$Data::Dumper::Indent    = 0;
 
35
$Data::Dumper::Quotekeys = 0;
 
36
 
 
37
eval {
 
38
   require DBI;
 
39
};
 
40
my $have_dbi = $EVAL_ERROR ? 0 : 1;
 
41
 
 
42
# Sub: new
 
43
#
 
44
# Parameters:
 
45
#   %args - Arguments
 
46
#
 
47
# Required Arguments:
 
48
#   opts - Hashref of DSN options, usually created in
 
49
#          <OptionParser::get_specs()>
 
50
#
 
51
# Returns:
 
52
#   DSNParser object
 
53
sub new {
 
54
   my ( $class, %args ) = @_;
 
55
   foreach my $arg ( qw(opts) ) {
 
56
      die "I need a $arg argument" unless $args{$arg};
 
57
   }
 
58
   my $self = {
 
59
      opts => {}  # h, P, u, etc.  Should come from DSN OPTIONS section in POD.
 
60
   };
 
61
   foreach my $opt ( @{$args{opts}} ) {
 
62
      if ( !$opt->{key} || !$opt->{desc} ) {
 
63
         die "Invalid DSN option: ", Dumper($opt);
 
64
      }
 
65
      MKDEBUG && _d('DSN option:',
 
66
         join(', ',
 
67
            map { "$_=" . (defined $opt->{$_} ? ($opt->{$_} || '') : 'undef') }
 
68
               keys %$opt
 
69
         )
 
70
      );
 
71
      $self->{opts}->{$opt->{key}} = {
 
72
         dsn  => $opt->{dsn},
 
73
         desc => $opt->{desc},
 
74
         copy => $opt->{copy} || 0,
 
75
      };
 
76
   }
 
77
   return bless $self, $class;
 
78
}
 
79
 
 
80
# Recognized properties:
 
81
# * dbidriver: which DBI driver to use; assumes mysql, supports Pg.
 
82
# * required:  which parts are required (hashref).
 
83
# * set-vars:  a list of variables to set after connecting
 
84
sub prop {
 
85
   my ( $self, $prop, $value ) = @_;
 
86
   if ( @_ > 2 ) {
 
87
      MKDEBUG && _d('Setting', $prop, 'property');
 
88
      $self->{$prop} = $value;
 
89
   }
 
90
   return $self->{$prop};
 
91
}
 
92
 
 
93
# Sub: parse
 
94
#   Parse a DSN string like "h=host,P=3306".
 
95
#
 
96
# Parameters:
 
97
#   $dsn      - DSN string
 
98
#   $prev     - Optional DSN hashref with previous DSN values
 
99
#   $defaults - Optional DSN hashref with default DSN values, used if a prop
 
100
#               isn't specified in $dsn or $prev
 
101
#
 
102
# Returns:
 
103
#   A DSN hashref like:
 
104
#   (start code)
 
105
#   {
 
106
#     D => 'database',
 
107
#     F => undef,
 
108
#     h => 'host',
 
109
#     p => 'mysql-password',
 
110
#     P => 3306,
 
111
#     S => undef,
 
112
#     t => 'table',
 
113
#     u => 'mysql-user',
 
114
#     A => undef,
 
115
#   }
 
116
#   (end code)
 
117
sub parse {
 
118
   my ( $self, $dsn, $prev, $defaults ) = @_;
 
119
   if ( !$dsn ) {
 
120
      MKDEBUG && _d('No DSN to parse');
 
121
      return;
 
122
   }
 
123
   MKDEBUG && _d('Parsing', $dsn);
 
124
   $prev     ||= {};
 
125
   $defaults ||= {};
 
126
   my %given_props;
 
127
   my %final_props;
 
128
   my $opts = $self->{opts};
 
129
 
 
130
   # Parse given props
 
131
   foreach my $dsn_part ( split(/,/, $dsn) ) {
 
132
      if ( my ($prop_key, $prop_val) = $dsn_part =~  m/^(.)=(.*)$/ ) {
 
133
         # Handle the typical DSN parts like h=host, P=3306, etc.
 
134
         $given_props{$prop_key} = $prop_val;
 
135
      }
 
136
      else {
 
137
         # Handle barewords
 
138
         MKDEBUG && _d('Interpreting', $dsn_part, 'as h=', $dsn_part);
 
139
         $given_props{h} = $dsn_part;
 
140
      }
 
141
   }
 
142
 
 
143
   # Fill in final props from given, previous, and/or default props
 
144
   foreach my $key ( keys %$opts ) {
 
145
      MKDEBUG && _d('Finding value for', $key);
 
146
      $final_props{$key} = $given_props{$key};
 
147
      if (   !defined $final_props{$key}
 
148
           && defined $prev->{$key} && $opts->{$key}->{copy} )
 
149
      {
 
150
         $final_props{$key} = $prev->{$key};
 
151
         MKDEBUG && _d('Copying value for', $key, 'from previous DSN');
 
152
      }
 
153
      if ( !defined $final_props{$key} ) {
 
154
         $final_props{$key} = $defaults->{$key};
 
155
         MKDEBUG && _d('Copying value for', $key, 'from defaults');
 
156
      }
 
157
   }
 
158
 
 
159
   # Sanity check props
 
160
   foreach my $key ( keys %given_props ) {
 
161
      die "Unknown DSN option '$key' in '$dsn'.  For more details, "
 
162
            . "please use the --help option, or try 'perldoc $PROGRAM_NAME' "
 
163
            . "for complete documentation."
 
164
         unless exists $opts->{$key};
 
165
   }
 
166
   if ( (my $required = $self->prop('required')) ) {
 
167
      foreach my $key ( keys %$required ) {
 
168
         die "Missing required DSN option '$key' in '$dsn'.  For more details, "
 
169
               . "please use the --help option, or try 'perldoc $PROGRAM_NAME' "
 
170
               . "for complete documentation."
 
171
            unless $final_props{$key};
 
172
      }
 
173
   }
 
174
 
 
175
   return \%final_props;
 
176
}
 
177
 
 
178
# Like parse() above but takes an OptionParser object instead of
 
179
# a DSN string.
 
180
sub parse_options {
 
181
   my ( $self, $o ) = @_;
 
182
   die 'I need an OptionParser object' unless ref $o eq 'OptionParser';
 
183
   my $dsn_string
 
184
      = join(',',
 
185
          map  { "$_=".$o->get($_); }
 
186
          grep { $o->has($_) && $o->get($_) }
 
187
          keys %{$self->{opts}}
 
188
        );
 
189
   MKDEBUG && _d('DSN string made from options:', $dsn_string);
 
190
   return $self->parse($dsn_string);
 
191
}
 
192
 
 
193
# $props is an optional arrayref of allowed DSN parts to
 
194
# include in the string.  So if you only want to stringify
 
195
# h and P, then pass [qw(h P)].
 
196
sub as_string {
 
197
   my ( $self, $dsn, $props ) = @_;
 
198
   return $dsn unless ref $dsn;
 
199
   my %allowed = $props ? map { $_=>1 } @$props : ();
 
200
   return join(',',
 
201
      map  { "$_=" . ($_ eq 'p' ? '...' : $dsn->{$_})  }
 
202
      grep { defined $dsn->{$_} && $self->{opts}->{$_} }
 
203
      grep { !$props || $allowed{$_}                   }
 
204
      sort keys %$dsn );
 
205
}
 
206
 
 
207
sub usage {
 
208
   my ( $self ) = @_;
 
209
   my $usage
 
210
      = "DSN syntax is key=value[,key=value...]  Allowable DSN keys:\n\n"
 
211
      . "  KEY  COPY  MEANING\n"
 
212
      . "  ===  ====  =============================================\n";
 
213
   my %opts = %{$self->{opts}};
 
214
   foreach my $key ( sort keys %opts ) {
 
215
      $usage .= "  $key    "
 
216
             .  ($opts{$key}->{copy} ? 'yes   ' : 'no    ')
 
217
             .  ($opts{$key}->{desc} || '[No description]')
 
218
             . "\n";
 
219
   }
 
220
   $usage .= "\n  If the DSN is a bareword, the word is treated as the 'h' key.\n";
 
221
   return $usage;
 
222
}
 
223
 
 
224
# Supports PostgreSQL via the dbidriver element of $info, but assumes MySQL by
 
225
# default.
 
226
sub get_cxn_params {
 
227
   my ( $self, $info ) = @_;
 
228
   my $dsn;
 
229
   my %opts = %{$self->{opts}};
 
230
   my $driver = $self->prop('dbidriver') || '';
 
231
   if ( $driver eq 'Pg' ) {
 
232
      $dsn = 'DBI:Pg:dbname=' . ( $info->{D} || '' ) . ';'
 
233
         . join(';', map  { "$opts{$_}->{dsn}=$info->{$_}" }
 
234
                     grep { defined $info->{$_} }
 
235
                     qw(h P));
 
236
   }
 
237
   else {
 
238
      $dsn = 'DBI:mysql:' . ( $info->{D} || '' ) . ';'
 
239
         . join(';', map  { "$opts{$_}->{dsn}=$info->{$_}" }
 
240
                     grep { defined $info->{$_} }
 
241
                     qw(F h P S A))
 
242
         . ';mysql_read_default_group=client';
 
243
   }
 
244
   MKDEBUG && _d($dsn);
 
245
   return ($dsn, $info->{u}, $info->{p});
 
246
}
 
247
 
 
248
# Fills in missing info from a DSN after successfully connecting to the server.
 
249
sub fill_in_dsn {
 
250
   my ( $self, $dbh, $dsn ) = @_;
 
251
   my $vars = $dbh->selectall_hashref('SHOW VARIABLES', 'Variable_name');
 
252
   my ($user, $db) = $dbh->selectrow_array('SELECT USER(), DATABASE()');
 
253
   $user =~ s/@.*//;
 
254
   $dsn->{h} ||= $vars->{hostname}->{Value};
 
255
   $dsn->{S} ||= $vars->{'socket'}->{Value};
 
256
   $dsn->{P} ||= $vars->{port}->{Value};
 
257
   $dsn->{u} ||= $user;
 
258
   $dsn->{D} ||= $db;
 
259
}
 
260
 
 
261
# Actually opens a connection, then sets some things on the connection so it is
 
262
# the way the Maatkit tools will expect.  Tools should NEVER open their own
 
263
# connection or use $dbh->reconnect, or these things will not take place!
 
264
sub get_dbh {
 
265
   my ( $self, $cxn_string, $user, $pass, $opts ) = @_;
 
266
   $opts ||= {};
 
267
   my $defaults = {
 
268
      AutoCommit         => 0,
 
269
      RaiseError         => 1,
 
270
      PrintError         => 0,
 
271
      ShowErrorStatement => 1,
 
272
      mysql_enable_utf8 => ($cxn_string =~ m/charset=utf8/i ? 1 : 0),
 
273
   };
 
274
   @{$defaults}{ keys %$opts } = values %$opts;
 
275
 
 
276
   # Only add this if explicitly set because we're not sure if
 
277
   # mysql_use_result=0 would leave default mysql_store_result
 
278
   # enabled.
 
279
   if ( $opts->{mysql_use_result} ) {
 
280
      $defaults->{mysql_use_result} = 1;
 
281
   }
 
282
 
 
283
   if ( !$have_dbi ) {
 
284
      die "Cannot connect to MySQL because the Perl DBI module is not "
 
285
         . "installed or not found.  Run 'perl -MDBI' to see the directories "
 
286
         . "that Perl searches for DBI.  If DBI is not installed, try:\n"
 
287
         . "  Debian/Ubuntu  apt-get install libdbi-perl\n"
 
288
         . "  RHEL/CentOS    yum install perl-DBI\n"
 
289
         . "  OpenSolaris    pgk install pkg:/SUNWpmdbi\n";
 
290
 
 
291
   }
 
292
 
 
293
   # Try twice to open the $dbh and set it up as desired.
 
294
   my $dbh;
 
295
   my $tries = 2;
 
296
   while ( !$dbh && $tries-- ) {
 
297
      MKDEBUG && _d($cxn_string, ' ', $user, ' ', $pass, 
 
298
         join(', ', map { "$_=>$defaults->{$_}" } keys %$defaults ));
 
299
 
 
300
      eval {
 
301
         $dbh = DBI->connect($cxn_string, $user, $pass, $defaults);
 
302
 
 
303
         # If it's a MySQL connection, set some options.
 
304
         if ( $cxn_string =~ m/mysql/i ) {
 
305
            my $sql;
 
306
 
 
307
            # Set SQL_MODE and options for SHOW CREATE TABLE.
 
308
            # Get current, server SQL mode.  Don't clobber this;
 
309
            # append our SQL mode to whatever is already set.
 
310
            # http://code.google.com/p/maatkit/issues/detail?id=801
 
311
            $sql = 'SELECT @@SQL_MODE';
 
312
            MKDEBUG && _d($dbh, $sql);
 
313
            my ($sql_mode) = $dbh->selectrow_array($sql);
 
314
 
 
315
            $sql = 'SET @@SQL_QUOTE_SHOW_CREATE = 1'
 
316
                 . '/*!40101, @@SQL_MODE=\'NO_AUTO_VALUE_ON_ZERO'
 
317
                 . ($sql_mode ? ",$sql_mode" : '')
 
318
                 . '\'*/';
 
319
            MKDEBUG && _d($dbh, $sql);
 
320
            $dbh->do($sql);
 
321
 
 
322
            # Set character set and binmode on STDOUT.
 
323
            if ( my ($charset) = $cxn_string =~ m/charset=(\w+)/ ) {
 
324
               $sql = "/*!40101 SET NAMES $charset*/";
 
325
               MKDEBUG && _d($dbh, ':', $sql);
 
326
               $dbh->do($sql);
 
327
               MKDEBUG && _d('Enabling charset for STDOUT');
 
328
               if ( $charset eq 'utf8' ) {
 
329
                  binmode(STDOUT, ':utf8')
 
330
                     or die "Can't binmode(STDOUT, ':utf8'): $OS_ERROR";
 
331
               }
 
332
               else {
 
333
                  binmode(STDOUT) or die "Can't binmode(STDOUT): $OS_ERROR";
 
334
               }
 
335
            }
 
336
 
 
337
            if ( $self->prop('set-vars') ) {
 
338
               $sql = "SET " . $self->prop('set-vars');
 
339
               MKDEBUG && _d($dbh, ':', $sql);
 
340
               $dbh->do($sql);
 
341
            }
 
342
         }
 
343
      };
 
344
      if ( !$dbh && $EVAL_ERROR ) {
 
345
         MKDEBUG && _d($EVAL_ERROR);
 
346
         if ( $EVAL_ERROR =~ m/not a compiled character set|character set utf8/ ) {
 
347
            MKDEBUG && _d('Going to try again without utf8 support');
 
348
            delete $defaults->{mysql_enable_utf8};
 
349
         }
 
350
         elsif ( $EVAL_ERROR =~ m/locate DBD\/mysql/i ) {
 
351
            die "Cannot connect to MySQL because the Perl DBD::mysql module is "
 
352
               . "not installed or not found.  Run 'perl -MDBD::mysql' to see "
 
353
               . "the directories that Perl searches for DBD::mysql.  If "
 
354
               . "DBD::mysql is not installed, try:\n"
 
355
               . "  Debian/Ubuntu  apt-get install libdbd-mysql-perl\n"
 
356
               . "  RHEL/CentOS    yum install perl-DBD-MySQL\n"
 
357
               . "  OpenSolaris    pgk install pkg:/SUNWapu13dbd-mysql\n";
 
358
         }
 
359
         if ( !$tries ) {
 
360
            die $EVAL_ERROR;
 
361
         }
 
362
      }
 
363
   }
 
364
 
 
365
   MKDEBUG && _d('DBH info: ',
 
366
      $dbh,
 
367
      Dumper($dbh->selectrow_hashref(
 
368
         'SELECT DATABASE(), CONNECTION_ID(), VERSION()/*!50038 , @@hostname*/')),
 
369
      'Connection info:',      $dbh->{mysql_hostinfo},
 
370
      'Character set info:',   Dumper($dbh->selectall_arrayref(
 
371
                     'SHOW VARIABLES LIKE "character_set%"', { Slice => {}})),
 
372
      '$DBD::mysql::VERSION:', $DBD::mysql::VERSION,
 
373
      '$DBI::VERSION:',        $DBI::VERSION,
 
374
   );
 
375
 
 
376
   return $dbh;
 
377
}
 
378
 
 
379
# Tries to figure out a hostname for the connection.
 
380
sub get_hostname {
 
381
   my ( $self, $dbh ) = @_;
 
382
   if ( my ($host) = ($dbh->{mysql_hostinfo} || '') =~ m/^(\w+) via/ ) {
 
383
      return $host;
 
384
   }
 
385
   my ( $hostname, $one ) = $dbh->selectrow_array(
 
386
      'SELECT /*!50038 @@hostname, */ 1');
 
387
   return $hostname;
 
388
}
 
389
 
 
390
# Disconnects a database handle, but complains verbosely if there are any active
 
391
# children.  These are usually $sth handles that haven't been finish()ed.
 
392
sub disconnect {
 
393
   my ( $self, $dbh ) = @_;
 
394
   MKDEBUG && $self->print_active_handles($dbh);
 
395
   $dbh->disconnect;
 
396
}
 
397
 
 
398
sub print_active_handles {
 
399
   my ( $self, $thing, $level ) = @_;
 
400
   $level ||= 0;
 
401
   printf("# Active %sh: %s %s %s\n", ($thing->{Type} || 'undef'), "\t" x $level,
 
402
      $thing, (($thing->{Type} || '') eq 'st' ? $thing->{Statement} || '' : ''))
 
403
      or die "Cannot print: $OS_ERROR";
 
404
   foreach my $handle ( grep {defined} @{ $thing->{ChildHandles} } ) {
 
405
      $self->print_active_handles( $handle, $level + 1 );
 
406
   }
 
407
}
 
408
 
 
409
# Copy all set vals in dsn_1 to dsn_2.  Existing val in dsn_2 are not
 
410
# overwritten unless overwrite=>1 is given, but undef never overwrites a
 
411
# val.
 
412
sub copy {
 
413
   my ( $self, $dsn_1, $dsn_2, %args ) = @_;
 
414
   die 'I need a dsn_1 argument' unless $dsn_1;
 
415
   die 'I need a dsn_2 argument' unless $dsn_2;
 
416
   my %new_dsn = map {
 
417
      my $key = $_;
 
418
      my $val;
 
419
      if ( $args{overwrite} ) {
 
420
         $val = defined $dsn_1->{$key} ? $dsn_1->{$key} : $dsn_2->{$key};
 
421
      }
 
422
      else {
 
423
         $val = defined $dsn_2->{$key} ? $dsn_2->{$key} : $dsn_1->{$key};
 
424
      }
 
425
      $key => $val;
 
426
   } keys %{$self->{opts}};
 
427
   return \%new_dsn;
 
428
}
 
429
 
 
430
sub _d {
 
431
   my ($package, undef, $line) = caller 0;
 
432
   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
 
433
        map { defined $_ ? $_ : 'undef' }
 
434
        @_;
 
435
   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
 
436
}
 
437
 
 
438
1;
 
439
}
 
440
# ###########################################################################
 
441
# End DSNParser package
 
442
# ###########################################################################