1#!/usr/bin/perl 2 3BEGIN { 4 die "The PERCONA_TOOLKIT_BRANCH environment variable is not set.\n" 5 unless $ENV{PERCONA_TOOLKIT_BRANCH} && -d $ENV{PERCONA_TOOLKIT_BRANCH}; 6 unshift @INC, "$ENV{PERCONA_TOOLKIT_BRANCH}/lib"; 7}; 8 9use strict; 10use warnings FATAL => 'all'; 11use English qw(-no_match_vars); 12use Test::More; 13use Data::Dumper; 14 15use Quoter; 16use PerconaTest; 17use DSNParser; 18use Sandbox; 19 20my $dp = new DSNParser(opts=>$dsn_opts); 21my $sb = new Sandbox(basedir => '/tmp', DSNParser => $dp); 22my $dbh = $sb->get_dbh_for('master'); 23 24my $q = new Quoter; 25 26is( 27 $q->quote('a'), 28 '`a`', 29 'Simple quote OK', 30); 31 32is( 33 $q->quote('a','b'), 34 '`a`.`b`', 35 'multi value', 36); 37 38is( 39 $q->quote('`a`'), 40 '```a```', 41 'already quoted', 42); 43 44is( 45 $q->quote('a`b'), 46 '`a``b`', 47 'internal quote', 48); 49 50is( 51 $q->quote('my db', 'my tbl'), 52 '`my db`.`my tbl`', 53 'quotes db with space and tbl with space' 54); 55 56is( $q->quote_val(1), "'1'", 'number' ); 57is( $q->quote_val('001'), "'001'", 'number with leading zero' ); 58# is( $q->quote_val(qw(1 2 3)), '1, 2, 3', 'three numbers'); 59is( $q->quote_val(qw(a)), "'a'", 'letter'); 60is( $q->quote_val("a'"), "'a\\''", 'letter with quotes'); 61is( $q->quote_val(undef), 'NULL', 'NULL'); 62is( $q->quote_val(''), "''", 'Empty string'); 63is( $q->quote_val('\\\''), "'\\\\\\\''", 'embedded backslash'); 64# is( $q->quote_val(42, 0), "'42'", 'non-numeric number' ); 65# is( $q->quote_val(42, 1), "42", 'number is numeric' ); 66is( $q->quote_val('123-abc'), "'123-abc'", 'looks numeric but is string'); 67is( $q->quote_val('123abc'), "'123abc'", 'looks numeric but is string'); 68is( $q->quote_val('0x89504E470'), '0x89504E470', 'hex string'); 69is( $q->quote_val('0x89504E470', is_char => 0), '0x89504E470', 'hex string, with is_char => 0'); 70is( $q->quote_val('0x89504E470', is_char => 1), "'0x89504E470'", 'hex string, with is_char => 1'); 71is( $q->quote_val('0x89504I470'), "'0x89504I470'", 'looks like hex string'); 72is( $q->quote_val('eastside0x3'), "'eastside0x3'", 'looks like hex str (issue 1110'); 73 74# Splitting DB and tbl apart 75is_deeply( 76 [$q->split_unquote("`db`.`tbl`")], 77 [qw(db tbl)], 78 'splits with a quoted db.tbl', 79); 80 81is_deeply( 82 [$q->split_unquote("db.tbl")], 83 [qw(db tbl)], 84 'splits with a db.tbl', 85); 86 87is_deeply( 88 [$q->split_unquote("tbl")], 89 [undef, 'tbl'], 90 'splits without a db', 91); 92 93is_deeply( 94 [$q->split_unquote("tbl", "db")], 95 [qw(db tbl)], 96 'splits with a db', 97); 98 99is_deeply( 100 [$q->split_unquote("`db`.`tb``l```")], 101 [qw(db tb`l`)], 102 'splits with a quoted db.tbl ad embedded quotes', 103); 104 105#TODO: { 106# local $::TODO = "Embedded periods not yet supported"; 107# is_deeply( 108# [$q->split_unquote("`d.b`.`tbl`")], 109# [qw(d.b tbl)], 110# 'splits with embedded periods: `d.b`.`tbl`', 111# ); 112#} 113 114is( $q->literal_like('foo'), "'foo'", 'LIKE foo'); 115is( $q->literal_like('foo_bar'), "'foo\\_bar'", 'LIKE foo_bar'); 116is( $q->literal_like('foo%bar'), "'foo\\%bar'", 'LIKE foo%bar'); 117is( $q->literal_like('v_b%a c_'), "'v\\_b\\%a c\\_'", 'LIKE v_b%a c_'); 118 119is( $q->join_quote('db', 'tbl'), '`db`.`tbl`', 'join_merge(db, tbl)' ); 120is( $q->join_quote(undef, 'tbl'), '`tbl`', 'join_merge(undef, tbl)' ); 121is( $q->join_quote('db', 'foo.tbl'), '`foo`.`tbl`', 'join_merge(db, foo.tbl)' ); 122is( $q->join_quote('`db`', '`tbl`'), '`db`.`tbl`', 'join_merge(`db`, `tbl`)' ); 123is( $q->join_quote(undef, '`tbl`'), '`tbl`', 'join_merge(undef, `tbl`)' ); 124is( $q->join_quote('`db`', '`foo`.`tbl`'), '`foo`.`tbl`', 'join_merge(`db`, `foo`.`tbl`)' ); 125 126# ########################################################################### 127# (de)serialize_list 128# ########################################################################### 129 130is( 131 $q->serialize_list( () ), 132 undef, 133 'Serialize empty list returns undef' 134); 135 136binmode(STDOUT, ':utf8') 137 or die "Can't binmode(STDOUT, ':utf8'): $OS_ERROR"; 138binmode(STDERR, ':utf8') 139 or die "Can't binmode(STDERR, ':utf8'): $OS_ERROR"; 140 141# Prevent "Wide character in print at Test/Builder.pm" warnings. 142binmode Test::More->builder->$_(), ':encoding(UTF-8)' 143 for qw(output failure_output); 144 145my @latin1_serialize_tests = ( 146 [ 'a' ], 147 [ 'a', 'b', ], 148 [ 'a,', 'b', ], # trailing comma 149 [ ',a', 'b', ], # leading comma 150 [ 'a', ',b' ], 151 [ 0 ], 152 [ 0, 0 ], 153 [ 1, 2 ], 154 [ '' ], # emptry string 155 [ '', '', '', ], 156 [ undef ], # NULL 157 [ undef, undef ], 158 [ undef, '' ], 159 [ '\N' ], # literal \N 160 [ "un caf\x{e9} na\x{ef}ve" ], # Latin-1 161 [ "\\," ], 162 [ '\\' ], 163 [ q/"abc\\", 'def'/ ], # Brian's pathalogical case 164); 165 166my @utf8_serialize_tests = ( 167 [ "\x{30cb} \x{e8}" ], # UTF-8 168); 169 170SKIP: { 171 skip 'Cannot connect to sandbox master', scalar @latin1_serialize_tests 172 unless $dbh; 173 174 $dbh->do('CREATE DATABASE IF NOT EXISTS serialize_test'); 175 $dbh->do('DROP TABLE IF EXISTS serialize_test.serialize'); 176 $dbh->do('CREATE TABLE serialize_test.serialize (id INT, textval TEXT, blobval BLOB)'); 177 # Ensure we are using lantin1 as the default for the connection 178 # From the documentation: 179 # This statement sets the three session system variables character_set_client, 180 # character_set_connection, and character_set_results to the given character set. 181 $dbh->do("SET NAMES 'latin1'"); 182 warn Data::Dumper::Dumper($dbh); 183 184 my $sth = $dbh->prepare( 185 "INSERT INTO serialize_test.serialize VALUES (?, ?, ?)" 186 ); 187 188 for my $test_index ( 0..$#latin1_serialize_tests ) { 189 190 # Flat, friendly name for the test string 191 my $flat_string 192 = "[" 193 . join( "][", 194 map { defined($_) ? $_ : 'undef' } 195 @{$latin1_serialize_tests[$test_index]}) 196 . "]"; 197 $flat_string =~ s/\n/\\n/g; 198 199 # INSERT the serialized list of values. 200 my $ser = $q->serialize_list( @{$latin1_serialize_tests[$test_index]} ); 201 $sth->execute($test_index, $ser, $ser); 202 203 # SELECT back the values and deserialize them. 204 my ($text_string) = $dbh->selectrow_array( 205 "SELECT textval FROM serialize_test.serialize WHERE id=$test_index"); 206 my @text_parts = $q->deserialize_list($text_string); 207 208 is_deeply( 209 \@text_parts, 210 $latin1_serialize_tests[$test_index], 211 "Serialize $flat_string" 212 ) or diag(Dumper($text_string, \@text_parts)); 213 } 214}; 215 216my $utf8_dbh = $sb->get_dbh_for('master'); 217$utf8_dbh->{mysql_enable_utf8} = 1; 218$utf8_dbh->do("SET NAMES 'utf8'"); 219SKIP: { 220 skip 'Cannot connect to sandbox master', scalar @utf8_serialize_tests 221 unless $utf8_dbh; 222 skip 'DBD::mysql 3.0007 has UTF-8 bug', scalar @utf8_serialize_tests 223 if $DBD::mysql::VERSION le '3.0007'; 224 225 $utf8_dbh->do("DROP TABLE serialize_test.serialize"); 226 $utf8_dbh->do("CREATE TABLE serialize_test.serialize (id INT, textval TEXT, blobval BLOB) CHARSET='utf8'"); 227 228 my $sth = $utf8_dbh->prepare( 229 "INSERT INTO serialize_test.serialize VALUES (?, ?, ?)" 230 ); 231 232 for my $test_index ( 0..$#utf8_serialize_tests ) { 233 234 # Flat, friendly name for the test string 235 my $flat_string 236 = "[" 237 . join( "][", 238 map { defined($_) ? $_ : 'undef' } 239 @{$utf8_serialize_tests[$test_index]}) 240 . "]"; 241 $flat_string =~ s/\n/\\n/g; 242 243 # INSERT the serialized list of values. 244 my $ser = $q->serialize_list( @{$utf8_serialize_tests[$test_index]} ); 245 $sth->execute($test_index, $ser, $ser); 246 247 # SELECT back the values and deserialize them. 248 my ($text_string) = $utf8_dbh->selectrow_array( 249 "SELECT textval FROM serialize_test.serialize WHERE id=$test_index"); 250 my @text_parts = $q->deserialize_list($text_string); 251 252 is_deeply( 253 \@text_parts, 254 $utf8_serialize_tests[$test_index], 255 "Serialize UTF-8 $flat_string" 256 ) or diag(Dumper($text_string, \@text_parts)); 257 } 258 259 $utf8_dbh->disconnect(); 260}; 261 262# ########################################################################### 263# Done. 264# ########################################################################### 265if ( $dbh ) { 266 $sb->wipe_clean($dbh); 267 $dbh->disconnect(); 268} 269ok($sb->ok(), "Sandbox servers") or BAIL_OUT(__FILE__ . " broke the sandbox"); 270done_testing; 271