graphicstest/uibench/scripts/mysql.pm
branchRCL_3
changeset 19 bbf46f59e123
equal deleted inserted replaced
18:57c618273d5c 19:bbf46f59e123
       
     1 # Copyright (C) 2002 Hiroyuki OYAMA. Japan. All rights reserved.
       
     2 # This program is free software: you can redistribute it and/or modify
       
     3 # it under the terms of the GNU General Public License as published by
       
     4 # the Free Software Foundation, either version 2 of the License, or
       
     5 # (at your option) any later version.
       
     6 #
       
     7 # This program is distributed in the hope that it will be useful,
       
     8 # but WITHOUT ANY WARRANTY; without even the implied warranty of
       
     9 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
       
    10 # GNU General Public License for more details.
       
    11 #
       
    12 # You should have received a copy of the GNU General Public License
       
    13 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
       
    14 
       
    15 package Net::MySQL;
       
    16 
       
    17 use 5.004;
       
    18 use IO::Socket;
       
    19 use Carp;
       
    20 use vars qw($VERSION $DEBUG);
       
    21 use strict;
       
    22 $VERSION = '0.09';
       
    23 
       
    24 use constant COMMAND_SLEEP          => "\x00";
       
    25 use constant COMMAND_QUIT           => "\x01";
       
    26 use constant COMMAND_INIT_DB        => "\x02";
       
    27 use constant COMMAND_QUERY          => "\x03";
       
    28 use constant COMMAND_FIELD_LIST     => "\x04";
       
    29 use constant COMMAND_CREATE_DB      => "\x05";
       
    30 use constant COMMAND_DROP_DB        => "\x06";
       
    31 use constant COMMAND_REFRESH        => "\x07";
       
    32 use constant COMMAND_SHUTDOWN       => "\x08";
       
    33 use constant COMMAND_STATISTICS     => "\x09";
       
    34 use constant COMMAND_PROCESS_INFO   => "\x0A";
       
    35 use constant COMMAND_CONNECT        => "\x0B";
       
    36 use constant COMMAND_PROCESS_KILL   => "\x0C";
       
    37 use constant COMMAND_DEBUG          => "\x0D";
       
    38 use constant COMMAND_PING           => "\x0E";
       
    39 use constant COMMAND_TIME           => "\x0F";
       
    40 use constant COMMAND_DELAYED_INSERT => "\x10";
       
    41 use constant COMMAND_CHANGE_USER    => "\x11";
       
    42 use constant COMMAND_BINLOG_DUMP    => "\x12";
       
    43 use constant COMMAND_TABLE_DUMP     => "\x13";
       
    44 use constant COMMAND_CONNECT_OUT    => "\x14";
       
    45 
       
    46 use constant DEFAULT_PORT_NUMBER => 3306;
       
    47 use constant BUFFER_LENGTH       => 1460;
       
    48 use constant DEFAULT_UNIX_SOCKET => '/tmp/mysql.sock';
       
    49 
       
    50 
       
    51 sub new
       
    52 {
       
    53 	my $class = shift;
       
    54 	my %args = @_;
       
    55 
       
    56 	my $self = bless {
       
    57 		hostname   => $args{hostname},
       
    58 		unixsocket => $args{unixsocket} || DEFAULT_UNIX_SOCKET,
       
    59 		port       => $args{port}       || DEFAULT_PORT_NUMBER,
       
    60 		database   => $args{database},
       
    61 		user       => $args{user},
       
    62 		password   => $args{password},
       
    63 		timeout    => $args{timeout}  || 60,
       
    64 		'socket'   => undef,
       
    65 		salt                 => '',
       
    66 		protocol_version     => undef,
       
    67 		client_capabilities  => 0,
       
    68 		affected_rows_length => 0,
       
    69 	}, $class;
       
    70 	$self->debug($args{debug});
       
    71 	$self->_initialize;
       
    72 	return $self;
       
    73 }
       
    74 
       
    75 
       
    76 sub query
       
    77 {
       
    78 	my $self = shift;
       
    79 	my $sql = join '', @_;
       
    80 	my $mysql = $self->{socket};
       
    81 
       
    82 	return $self->_execute_command(COMMAND_QUERY, $sql);
       
    83 }
       
    84 
       
    85 
       
    86 sub create_database
       
    87 {
       
    88 	my $self = shift;
       
    89 	my $db_name = shift;
       
    90 	my $mysql = $self->{socket};
       
    91 
       
    92 	return $self->_execute_command(COMMAND_CREATE_DB, $db_name);
       
    93 }
       
    94 
       
    95 
       
    96 sub drop_database
       
    97 {
       
    98 	my $self = shift;
       
    99 	my $db_name = shift;
       
   100 	my $mysql = $self->{socket};
       
   101 
       
   102 	return $self->_execute_command(COMMAND_DROP_DB, $db_name);
       
   103 }
       
   104 
       
   105 
       
   106 sub close
       
   107 {
       
   108 	my $self = shift;
       
   109 	my $mysql = $self->{socket};
       
   110 	return unless $mysql->can('send');
       
   111 
       
   112 	my $quit_message =
       
   113 		chr(length(COMMAND_QUIT)). "\x00\x00\x00". COMMAND_QUIT;
       
   114 	$mysql->send($quit_message, 0);
       
   115 	$self->_dump_packet($quit_message) if Net::MySQL->debug;
       
   116 	$mysql->close;
       
   117 }
       
   118 
       
   119 
       
   120 sub get_affected_rows_length
       
   121 {
       
   122 	my $self = shift;
       
   123 	$self->{affected_rows_length};
       
   124 }
       
   125 
       
   126 
       
   127 sub get_insert_id
       
   128 {
       
   129 	my $self = shift;
       
   130 	$self->{insert_id};
       
   131 }
       
   132 
       
   133 
       
   134 sub create_record_iterator
       
   135 {
       
   136 	my $self = shift;
       
   137 	return undef unless $self->has_selected_record;
       
   138 
       
   139 	my $record = Net::MySQL::RecordIterator->new(
       
   140 		$self->{selected_record}
       
   141 	);
       
   142 	$self->{selected_record} = undef;
       
   143 	$record->parse;
       
   144 	return $record;
       
   145 }
       
   146 
       
   147 
       
   148 sub has_selected_record
       
   149 {
       
   150 	my $self = shift;
       
   151 	$self->{selected_record} ? 1 : undef;
       
   152 }
       
   153 
       
   154 
       
   155 sub is_error
       
   156 {
       
   157 	my $self = shift;
       
   158 	$self->{error_code} ? 1 : undef;
       
   159 }
       
   160 
       
   161 
       
   162 sub get_error_code
       
   163 {
       
   164 	my $self = shift;
       
   165 	$self->{error_code};
       
   166 }
       
   167 
       
   168 
       
   169 sub get_error_message
       
   170 {
       
   171 	my $self = shift;
       
   172 	$self->{server_message};
       
   173 }
       
   174 
       
   175 
       
   176 sub debug
       
   177 {
       
   178 	my $class = shift;
       
   179 	$DEBUG = shift if @_;
       
   180 	$DEBUG;
       
   181 }
       
   182 
       
   183 
       
   184 sub _connect
       
   185 {
       
   186 	my $self = shift;
       
   187 
       
   188 	my $mysql;
       
   189 	if ($self->{hostname}) {
       
   190 		printf "Use INET Socket: %s %d/tcp\n", $self->{hostname}, $self->{port}
       
   191 			if $self->debug;
       
   192 		$mysql = IO::Socket::INET->new(
       
   193 			PeerAddr => $self->{hostname},
       
   194 			PeerPort => $self->{port},
       
   195 			Proto    => 'tcp',
       
   196 			Timeout  => $self->{timeout} || 60,
       
   197 		) or croak "Couldn't connect to $self->{hostname}:$self->{port}/tcp: $@";
       
   198 	}
       
   199 	else {
       
   200 		printf "Use UNIX Socket: %s\n", $self->{unixsocket} if $self->debug;
       
   201 		$mysql = IO::Socket::UNIX->new(
       
   202 			Type => SOCK_STREAM,
       
   203 			Peer => $self->{unixsocket},
       
   204 		) or croak "Couldn't connect to $self->{unixsocket}: $@";
       
   205 	}
       
   206 	$mysql->autoflush(1);
       
   207 	$self->{socket} = $mysql;
       
   208 }
       
   209 
       
   210 
       
   211 sub _get_server_information
       
   212 {
       
   213 	my $self = shift;
       
   214 	my $mysql = $self->{socket};
       
   215 
       
   216 	my $message;
       
   217 	$mysql->recv($message, BUFFER_LENGTH, 0);
       
   218 	$self->_dump_packet($message)
       
   219 		if Net::MySQL->debug;
       
   220 	my $i = 0;
       
   221 	my $packet_length = ord substr $message, $i, 1;
       
   222 	$i += 4;
       
   223 	$self->{protocol_version} = ord substr $message, $i, 1;
       
   224 	printf "Protocol Version: %d\n", $self->{protocol_version}
       
   225 		if Net::MySQL->debug;
       
   226 	if ($self->{protocol_version} == 10) {
       
   227 		$self->{client_capabilities} = 1;
       
   228 	}
       
   229 
       
   230 	++$i;
       
   231 	my $string_end = index($message, "\0", $i) - $i;
       
   232 	$self->{server_version} = substr $message, $i, $string_end;
       
   233 	printf "Server Version: %s\n", $self->{server_version}
       
   234 		if Net::MySQL->debug;
       
   235 
       
   236 	$i += $string_end + 1;
       
   237 	$self->{server_thread_id} = unpack 'v', substr $message, $i, 2;
       
   238 	$i += 4;
       
   239 	$self->{salt} = substr $message, $i, 8;
       
   240 	#
       
   241 	$i += 8+1;
       
   242 	if (length $message >= $i + 1) {
       
   243 		$i += 1;
       
   244 	}
       
   245 	if (length $message >= $i + 18) {
       
   246 		# get server_language
       
   247 		# get server_status
       
   248 	}
       
   249 	$i += 18 - 1;
       
   250 	if (length $message >= $i + 12 - 1) {
       
   251 		$self->{salt} .= substr $message, $i, 12;
       
   252 	}
       
   253 	printf "Salt: %s\n", $self->{salt} if Net::MySQL->debug;
       
   254 
       
   255 }
       
   256 
       
   257 
       
   258 sub _request_authentication
       
   259 {
       
   260 	my $self = shift;
       
   261 	my $mysql = $self->{socket};
       
   262 	$self->_send_login_message();
       
   263 
       
   264 	my $auth_result;
       
   265 	$mysql->recv($auth_result, BUFFER_LENGTH, 0);
       
   266 	$self->_dump_packet($auth_result) if Net::MySQL->debug;
       
   267 	if ($self->_is_error($auth_result)) {
       
   268 		$mysql->close;
       
   269 		if (length $auth_result < 7) {
       
   270 			croak "Timeout of authentication";
       
   271 		}
       
   272 		croak substr $auth_result, 7;
       
   273 	}
       
   274 	print "connect database\n" if Net::MySQL->debug;
       
   275 }
       
   276 
       
   277 
       
   278 sub _send_login_message
       
   279 {
       
   280 	my $self = shift;
       
   281 	my $mysql = $self->{socket};
       
   282 	my $body = "\0\0\x01\x0d\xa6\03\0\0\0\0\x01".
       
   283 		"\x21\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0".
       
   284 		 join "\0",
       
   285 		$self->{user},
       
   286 		"\x14".
       
   287 		Net::MySQL::Password->scramble(
       
   288 			$self->{password}, $self->{salt}, $self->{client_capabilities}
       
   289 		);
       
   290 	$body .= $self->{database};
       
   291 	$body .= "\0";
       
   292 	my $login_message = chr(length($body)-3). $body;
       
   293 	$mysql->send($login_message, 0);
       
   294 	$self->_dump_packet($login_message) if Net::MySQL->debug;
       
   295 }
       
   296 
       
   297 
       
   298 
       
   299 sub _execute_command
       
   300 {
       
   301 	my $self = shift;
       
   302 	my $command = shift;
       
   303 	my $sql = shift;
       
   304 	my $mysql = $self->{socket};
       
   305 
       
   306 	my $message = pack('V', length($sql) + 1). $command. $sql;
       
   307 	$mysql->send($message, 0);
       
   308 	$self->_dump_packet($message) if Net::MySQL->debug;
       
   309 
       
   310 	my $result;
       
   311 	$mysql->recv($result, BUFFER_LENGTH, 0);
       
   312 	$self->_dump_packet($result) if Net::MySQL->debug;
       
   313 	$self->_reset_status;
       
   314 
       
   315 	if ($self->_is_error($result)) {
       
   316 		return $self->_set_error_by_packet($result);
       
   317 	}
       
   318 	elsif ($self->_is_select_query_result($result)) {
       
   319 		return $self->_get_record_by_server($result);
       
   320 	}
       
   321 	elsif ($self->_is_update_query_result($result)){
       
   322 		return $self->_get_affected_rows_information_by_packet($result);
       
   323 	}
       
   324 	else {
       
   325 		croak 'Unknown Result: '. $self->_get_result_length($result). 'byte';
       
   326 	}
       
   327 }
       
   328 
       
   329 
       
   330 sub _initialize
       
   331 {
       
   332 	my $self = shift;
       
   333 	$self->_connect;
       
   334 	$self->_get_server_information;
       
   335 	$self->_request_authentication;
       
   336 }
       
   337 
       
   338 
       
   339 sub _set_error_by_packet
       
   340 {
       
   341 	my $self = shift;
       
   342 	my $packet = shift;
       
   343 
       
   344 	my $error_message = $self->_get_server_message($packet);
       
   345 	$self->{server_message} = $error_message;
       
   346 	$self->{error_code}     = $self->_get_error_code($packet);
       
   347 	return undef;
       
   348 }
       
   349 
       
   350 
       
   351 sub _get_record_by_server
       
   352 {
       
   353 	my $self = shift;
       
   354 	my $packet = shift;
       
   355 	my $mysql = $self->{socket};
       
   356 	$self->_get_column_length($packet);
       
   357 	while ($self->_has_next_packet($packet)) {
       
   358 		my $next_result;
       
   359 		$mysql->recv($next_result, BUFFER_LENGTH, 0);
       
   360 		$packet .= $next_result;
       
   361 		$self->_dump_packet($next_result) if Net::MySQL->debug;
       
   362 	}
       
   363 	$self->{selected_record} = $packet;
       
   364 }
       
   365 
       
   366 
       
   367 sub _get_affected_rows_information_by_packet
       
   368 {
       
   369 	my $self = shift;
       
   370 	my $packet = shift;
       
   371 
       
   372 	$self->{affected_rows_length} = $self->_get_affected_rows_length($packet);
       
   373 	$self->{insert_id} = $self->_get_insert_id($packet);
       
   374 	$self->{server_message} = $self->_get_server_message($packet);
       
   375 	return $self->{affected_rows_length};
       
   376 }
       
   377 
       
   378 
       
   379 sub _is_error
       
   380 {
       
   381 	my $self = shift;
       
   382 	my $packet = shift;
       
   383 	return 1 if length $packet < 4;
       
   384 	ord(substr $packet, 4) == 255;
       
   385 }
       
   386 
       
   387 
       
   388 sub _is_select_query_result
       
   389 {
       
   390 	my $self = shift;
       
   391 	my $packet = shift;
       
   392 	return undef if $self->_is_error($packet);
       
   393 	ord(substr $packet, 4) >= 1;
       
   394 }
       
   395 
       
   396 
       
   397 sub _is_update_query_result
       
   398 {
       
   399 	my $self = shift;
       
   400 	my $packet = shift;
       
   401 	return undef if $self->_is_error($packet);
       
   402 	ord(substr $packet, 4) == 0;
       
   403 }
       
   404 
       
   405 
       
   406 sub _get_result_length
       
   407 {
       
   408 	my $self = shift;
       
   409 	my $packet = shift;
       
   410 	ord(substr $packet, 0, 1)
       
   411 }
       
   412 
       
   413 
       
   414 sub _get_column_length
       
   415 {
       
   416 	my $self = shift;
       
   417 	my $packet = shift;
       
   418 	ord(substr $packet, 4);
       
   419 }
       
   420 
       
   421 
       
   422 sub _get_affected_rows_length
       
   423 {
       
   424 	my $self = shift;
       
   425 	my $packet = shift;
       
   426 	my $pos = 5;
       
   427 	return Net::MySQL::Util::get_field_length($packet, \$pos);
       
   428 }
       
   429 
       
   430 
       
   431 sub _get_insert_id
       
   432 {
       
   433 	my $self = shift;
       
   434 	my $packet = shift;
       
   435 	return ord(substr $packet, 6, 1) if ord(substr $packet, 6, 1) != 0xfc;
       
   436 	unpack 'v', substr $packet, 7, 2;
       
   437 }
       
   438 
       
   439 
       
   440 sub _get_server_message
       
   441 {
       
   442 	my $self = shift;
       
   443 	my $packet = shift;
       
   444 	return '' if length $packet < 7;
       
   445 	substr $packet, 7;
       
   446 }
       
   447 
       
   448 
       
   449 sub _get_error_code
       
   450 {
       
   451 	my $self = shift;
       
   452 	my $packet = shift;
       
   453 	$self->_is_error($packet)
       
   454 		or croak "_get_error_code(): Is not error packet";
       
   455 	unpack 'v', substr $packet, 5, 2;
       
   456 }
       
   457 
       
   458 
       
   459 sub _reset_status
       
   460 {
       
   461 	my $self = shift;
       
   462 	$self->{insert_id}       = 0;
       
   463 	$self->{server_message}  = '';
       
   464 	$self->{error_code}      = undef;
       
   465 	$self->{selected_record} = undef;
       
   466 }
       
   467 
       
   468 
       
   469 sub _has_next_packet
       
   470 {
       
   471 	my $self = shift;
       
   472 	#substr($_[0], -1) ne "\xfe";
       
   473 	return substr($_[0], -5) ne "\xfe\0\0\x22\x00";
       
   474 }
       
   475 
       
   476 
       
   477 sub _dump_packet {
       
   478     my $self = shift;
       
   479     my $packet = shift;
       
   480     my ($method_name) = (caller(1))[3];
       
   481     my $str = sprintf "%s():\n", $method_name;
       
   482     while ($packet =~ /(.{1,16})/sg) {
       
   483         my $line = $1;
       
   484         $str .= join ' ', map {sprintf '%02X', ord $_} split //, $line;
       
   485         $str .= '   ' x (16 - length $line);
       
   486         $str .= '  ';
       
   487         $str .= join '', map {
       
   488             sprintf '%s', (/[\w\d\*\,\?\%\=\'\;\(\)\.-]/) ? $_ : '.'
       
   489         } split //, $line;
       
   490         $str .= "\n"; 
       
   491     }
       
   492     print $str;
       
   493 }
       
   494 
       
   495 
       
   496 
       
   497 package Net::MySQL::RecordIterator;
       
   498 use strict;
       
   499 
       
   500 use constant NULL_COLUMN           => 251;
       
   501 use constant UNSIGNED_CHAR_COLUMN  => 251;
       
   502 use constant UNSIGNED_SHORT_COLUMN => 252;
       
   503 use constant UNSIGNED_INT24_COLUMN => 253;
       
   504 use constant UNSIGNED_INT32_COLUMN => 254;
       
   505 use constant UNSIGNED_CHAR_LENGTH  => 1;
       
   506 use constant UNSIGNED_SHORT_LENGTH => 2;
       
   507 use constant UNSIGNED_INT24_LENGTH => 3;
       
   508 use constant UNSIGNED_INT32_LENGTH => 4;
       
   509 use constant UNSIGNED_INT32_PAD_LENGTH => 4;
       
   510 
       
   511 
       
   512 sub new
       
   513 {
       
   514 	my $class = shift;
       
   515 	my $packet = shift;
       
   516 	bless {
       
   517 		packet   => $packet,
       
   518 		position => 0,
       
   519 		column   => [],
       
   520 	}, $class;
       
   521 }
       
   522 
       
   523 
       
   524 sub parse
       
   525 {
       
   526 	my $self = shift;
       
   527 	$self->_get_column_length;
       
   528 	$self->_get_column_name;
       
   529 }
       
   530 
       
   531 
       
   532 sub each
       
   533 {
       
   534 	my $self = shift;
       
   535 	my @result;
       
   536 	return undef if $self->is_end_of_packet;
       
   537 
       
   538 	for (1..$self->{column_length}) {
       
   539 		push @result, $self->_get_string_and_seek_position;
       
   540 	}
       
   541 	$self->{position} += 4;
       
   542 
       
   543 	return \@result;
       
   544 }
       
   545 
       
   546 
       
   547 sub is_end_of_packet
       
   548 {
       
   549 	my $self = shift;
       
   550 	return substr($self->{packet}, $self->{position}, 1) eq "\xFE";
       
   551 }
       
   552 
       
   553 
       
   554 sub get_field_length
       
   555 {
       
   556 	my $self = shift;
       
   557 	$self->{column_length};
       
   558 }
       
   559 
       
   560 
       
   561 sub get_field_names
       
   562 {
       
   563 	my $self = shift;
       
   564 	map { $_->{column} } @{$self->{column}};
       
   565 }
       
   566 
       
   567 
       
   568 sub _get_column_length
       
   569 {
       
   570 	my $self = shift;
       
   571 	$self->{position} += 4;
       
   572 	$self->{column_length} = ord substr $self->{packet}, $self->{position}, 1;
       
   573 	$self->{position} += 5;
       
   574 	printf "Column Length: %d\n", $self->{column_length}
       
   575 		if Net::MySQL->debug;
       
   576 }
       
   577 
       
   578 
       
   579 sub _get_column_name
       
   580 {
       
   581 	my $self = shift;
       
   582 
       
   583 	for my $i (1.. $self->{column_length}) {
       
   584 		$self->_get_string_and_seek_position;
       
   585 		$self->_get_string_and_seek_position;
       
   586 		my $table = $self->_get_string_and_seek_position;
       
   587 		$self->_get_string_and_seek_position;
       
   588 		my $column = $self->_get_string_and_seek_position;
       
   589 		$self->_get_string_and_seek_position;
       
   590 		push @{$self->{column}}, {
       
   591 			table  => $table,
       
   592 			column => $column,
       
   593 		};
       
   594 		$self->_get_string_and_seek_position;
       
   595 		$self->{position} += 4;
       
   596 	}
       
   597 	$self->{position} += 9;
       
   598 	printf "Column name: '%s'\n",
       
   599 		join ", ", map { $_->{column} } @{$self->{column}}
       
   600 			if Net::MySQL->debug;
       
   601 }
       
   602 
       
   603 
       
   604 sub _get_string_and_seek_position
       
   605 {
       
   606 	my $self = shift;
       
   607 
       
   608 	my $length = $self->_get_field_length();
       
   609 
       
   610 	return undef unless defined $length;
       
   611 
       
   612 	my $string = substr $self->{packet}, $self->{position}, $length;
       
   613 	$self->{position} += $length;
       
   614 	return $string;
       
   615 }
       
   616 
       
   617 
       
   618 sub _get_field_length
       
   619 {
       
   620 	my $self = shift;
       
   621 	return Net::MySQL::Util::get_field_length($self->{packet}, \$self->{position});
       
   622 }
       
   623 
       
   624 
       
   625 package Net::MySQL::Util;
       
   626 use strict;
       
   627 
       
   628 use constant NULL_COLUMN           => 251;
       
   629 use constant UNSIGNED_CHAR_COLUMN  => 251;
       
   630 use constant UNSIGNED_SHORT_COLUMN => 252;
       
   631 use constant UNSIGNED_INT24_COLUMN => 253;
       
   632 use constant UNSIGNED_INT32_COLUMN => 254;
       
   633 use constant UNSIGNED_CHAR_LENGTH  => 1;
       
   634 use constant UNSIGNED_SHORT_LENGTH => 2;
       
   635 use constant UNSIGNED_INT24_LENGTH => 3;
       
   636 use constant UNSIGNED_INT32_LENGTH => 4;
       
   637 use constant UNSIGNED_INT32_PAD_LENGTH => 4;
       
   638 
       
   639 
       
   640 sub get_field_length
       
   641 {
       
   642 	my $packet = shift;
       
   643 	my $pos = shift;
       
   644 
       
   645 	my $head = ord substr(
       
   646 		$packet,
       
   647 		$$pos,
       
   648 		UNSIGNED_CHAR_LENGTH
       
   649 	);
       
   650 	$$pos += UNSIGNED_CHAR_LENGTH;
       
   651 
       
   652 	return undef if $head == NULL_COLUMN;
       
   653 	if ($head < UNSIGNED_CHAR_COLUMN) {
       
   654 		return $head;
       
   655 	}
       
   656 	elsif ($head == UNSIGNED_SHORT_COLUMN) {
       
   657 		my $length = unpack 'v', substr(
       
   658 			$packet,
       
   659 			$$pos,
       
   660 			UNSIGNED_SHORT_LENGTH
       
   661 		);
       
   662 		$$pos += UNSIGNED_SHORT_LENGTH;
       
   663 		return $length;
       
   664 	}
       
   665 	elsif ($head == UNSIGNED_INT24_COLUMN) {
       
   666 		my $int24 = substr(
       
   667 			$packet, $$pos,
       
   668 			UNSIGNED_INT24_LENGTH
       
   669 		);
       
   670 		my $length = unpack('C', substr($int24, 0, 1))
       
   671 		          + (unpack('C', substr($int24, 1, 1)) << 8)
       
   672 			  + (unpack('C', substr($int24, 2, 1)) << 16);
       
   673 		$$pos += UNSIGNED_INT24_LENGTH;
       
   674 		return $length;
       
   675 	}
       
   676 	else {
       
   677 		my $int32 = substr(
       
   678 			$packet, $$pos,
       
   679 			UNSIGNED_INT32_LENGTH
       
   680 		);
       
   681 		my $length = unpack('C', substr($int32, 0, 1))
       
   682 		          + (unpack('C', substr($int32, 1, 1)) << 8)
       
   683 			  + (unpack('C', substr($int32, 2, 1)) << 16)
       
   684 			  + (unpack('C', substr($int32, 3, 1)) << 24);
       
   685 		$$pos += UNSIGNED_INT32_LENGTH;
       
   686 		$$pos += UNSIGNED_INT32_PAD_LENGTH;
       
   687 		return $length;
       
   688 	}
       
   689 }
       
   690 
       
   691 
       
   692 
       
   693 package Net::MySQL::Password;
       
   694 use strict;
       
   695 use Digest::SHA1;
       
   696 
       
   697 sub scramble {
       
   698 	my $class = shift;
       
   699 	my $password = shift;
       
   700 	my $hash_seed = shift;
       
   701 	return '' unless $password;
       
   702 	return '' if length $password == 0;
       
   703 	return _make_scrambled_password($hash_seed, $password);
       
   704 }
       
   705 
       
   706 
       
   707 sub _make_scrambled_password {
       
   708 	my $message = shift;
       
   709 	my $password = shift;
       
   710 
       
   711 	my $ctx = Digest::SHA1->new;
       
   712 	$ctx->reset;
       
   713 	$ctx->add($password);
       
   714 	my $stage1 = $ctx->digest;
       
   715 
       
   716 	$ctx->reset;
       
   717 	$ctx->add($stage1);
       
   718 	my $stage2 = $ctx->digest;
       
   719 
       
   720 	$ctx->reset;
       
   721 	$ctx->add($message);
       
   722 	$ctx->add($stage2);
       
   723 	my $result = $ctx->digest;
       
   724 	return _my_crypt($result, $stage1);
       
   725 }
       
   726 
       
   727 sub _my_crypt {
       
   728 	my $s1 = shift;
       
   729 	my $s2 = shift;
       
   730 	my $l = length($s1) - 1;
       
   731 	my $result = '';
       
   732 	for my $i (0..$l) {
       
   733 		$result .= pack 'C', (unpack('C', substr($s1, $i, 1)) ^ unpack('C', substr($s2, $i, 1)));
       
   734 	}
       
   735 	return $result;
       
   736 }
       
   737 
       
   738 package Net::MySQL::Password32;
       
   739 use strict;
       
   740 
       
   741 sub scramble
       
   742 {
       
   743 	my $class = shift;
       
   744 	my $password = shift;
       
   745 	my $hash_seed = shift;
       
   746 	my $client_capabilities = shift;
       
   747 
       
   748 	return '' unless $password;
       
   749 	return '' if length $password == 0;
       
   750 
       
   751 	my $hsl = length $hash_seed;
       
   752 	my @out;
       
   753 	my @hash_pass = _get_hash($password);
       
   754 	my @hash_mess = _get_hash($hash_seed);
       
   755 
       
   756 	my ($max_value, $seed, $seed2);
       
   757 	my ($dRes, $dSeed, $dMax);
       
   758 	if ($client_capabilities < 1) {
       
   759 		$max_value = 0x01FFFFFF;
       
   760 		$seed = _xor_by_long($hash_pass[0], $hash_mess[0]) % $max_value;
       
   761 		$seed2 = int($seed / 2);
       
   762 	} else {
       
   763 		$max_value= 0x3FFFFFFF;
       
   764 		$seed  = _xor_by_long($hash_pass[0], $hash_mess[0]) % $max_value;
       
   765 		$seed2 = _xor_by_long($hash_pass[1], $hash_mess[1]) % $max_value;
       
   766 	}
       
   767 	$dMax = $max_value;
       
   768 
       
   769 	for (my $i=0; $i < $hsl; $i++) {
       
   770 		$seed  = int(($seed * 3 + $seed2) % $max_value);
       
   771 		$seed2 = int(($seed + $seed2 + 33) % $max_value);
       
   772 		$dSeed = $seed;
       
   773 		$dRes = $dSeed / $dMax;
       
   774 		push @out, int($dRes * 31) + 64;
       
   775 	}
       
   776 
       
   777 	if ($client_capabilities == 1) {
       
   778 		# Make it harder to break
       
   779 		$seed  = ($seed * 3 + $seed2  ) % $max_value;
       
   780 		$seed2 = ($seed + $seed2 + 33 ) % $max_value;
       
   781 		$dSeed = $seed;
       
   782 
       
   783 		$dRes = $dSeed / $dMax;
       
   784 		my $e = int($dRes * 31);
       
   785 		for (my $i=0; $i < $hsl ; $i++) {
       
   786 			$out[$i] ^= $e;
       
   787 		}
       
   788 	}
       
   789 	return join '', map { chr $_ } @out;
       
   790 }
       
   791 
       
   792 
       
   793 sub _get_hash
       
   794 {
       
   795 	my $password = shift;
       
   796 
       
   797 	my $nr = 1345345333;
       
   798 	my $add = 7; 
       
   799 	my $nr2 = 0x12345671;
       
   800 	my $tmp;
       
   801 	my $pwlen = length $password;
       
   802 	my $c;
       
   803 
       
   804 	for (my $i=0; $i < $pwlen; $i++) {
       
   805 		my $c = substr $password, $i, 1;
       
   806 		next if $c eq ' ' || $c eq "\t";
       
   807 		my $tmp = ord $c;
       
   808 		my $value = ((_and_by_char($nr, 63) + $add) * $tmp) + $nr * 256;
       
   809 		$nr = _xor_by_long($nr, $value);
       
   810 		$nr2 += _xor_by_long(($nr2 * 256), $nr);
       
   811 		$add += $tmp;
       
   812 	}
       
   813 	return (_and_by_long($nr, 0x7fffffff), _and_by_long($nr2, 0x7fffffff));
       
   814 }
       
   815 
       
   816 
       
   817 sub _and_by_char
       
   818 {
       
   819 	my $source = shift;
       
   820 	my $mask   = shift;
       
   821 
       
   822 	return $source & $mask;
       
   823 }
       
   824 
       
   825 
       
   826 sub _and_by_long
       
   827 {
       
   828 	my $source = shift;
       
   829 	my $mask = shift || 0xFFFFFFFF;
       
   830 
       
   831 	return _cut_off_to_long($source) & _cut_off_to_long($mask);
       
   832 }
       
   833 
       
   834 
       
   835 sub _xor_by_long
       
   836 {
       
   837 	my $source = shift;
       
   838 	my $mask = shift || 0;
       
   839 
       
   840 	return _cut_off_to_long($source) ^ _cut_off_to_long($mask);
       
   841 }
       
   842 
       
   843 
       
   844 sub _cut_off_to_long
       
   845 {
       
   846 	my $source = shift;
       
   847 
       
   848 	if ($] >= 5.006) {
       
   849 		$source = $source % (0xFFFFFFFF + 1) if $source > 0xFFFFFFFF;
       
   850 		return $source;
       
   851 	}
       
   852 	while ($source > 0xFFFFFFFF) {
       
   853 		$source -= 0xFFFFFFFF + 1;
       
   854 	}
       
   855 	return $source;
       
   856 }
       
   857 
       
   858 
       
   859 1;
       
   860 __END__
       
   861 
       
   862 =head1 NAME
       
   863 
       
   864 Net::MySQL - Pure Perl MySQL network protocol interface.
       
   865 
       
   866 =head1 SYNOPSIS
       
   867 
       
   868   use Net::MySQL;
       
   869   
       
   870   my $mysql = Net::MySQL->new(
       
   871       # hostname => 'mysql.example.jp',   # Default use UNIX socket
       
   872       database => 'your_database_name',
       
   873       user     => 'user',
       
   874       password => 'password'
       
   875   );
       
   876 
       
   877   # INSERT example
       
   878   $mysql->query(q{
       
   879       INSERT INTO tablename (first, next) VALUES ('Hello', 'World')
       
   880   });
       
   881   printf "Affected row: %d\n", $mysql->get_affected_rows_length;
       
   882 
       
   883   # SLECT example
       
   884   $mysql->query(q{SELECT * FROM tablename});
       
   885   my $record_set = $mysql->create_record_iterator;
       
   886   while (my $record = $record_set->each) {
       
   887       printf "First column: %s Next column: %s\n",
       
   888           $record->[0], $record->[1];
       
   889   }
       
   890   $mysql->close;
       
   891 
       
   892 =head1 DESCRIPTION
       
   893 
       
   894 Net::MySQL is a Pure Perl client interface for the MySQL database. This module implements network protocol between server and client of MySQL, thus you don't need external MySQL client library like libmysqlclient for this module to work. It means this module enables you to connect to MySQL server from some operation systems which MySQL is not ported. How nifty!
       
   895 
       
   896 Since this module's final goal is to completely replace DBD::mysql, API is made similar to that of DBI.
       
   897 
       
   898 From perl you activate the interface with the statement
       
   899 
       
   900     use Net::MySQL;
       
   901 
       
   902 After that you can connect to multiple MySQL daemon and send multiple queries to any of them via a simple object oriented interface.
       
   903 
       
   904 There are two classes which have public APIs: Net::MySQL and Net::MySQL::RecordIterator.
       
   905 
       
   906     $mysql = Net::MySQL->new(
       
   907         hostname => $host,
       
   908         database => $database,
       
   909         user     => $user,
       
   910         password => $password,
       
   911     );
       
   912 
       
   913 Once you have connected to a daemon, you can can execute SQL with:
       
   914 
       
   915     $mysql->query(q{
       
   916         INSERT INTO foo (id, message) VALUES (1, 'Hello World')
       
   917     });
       
   918 
       
   919 If you want to retrieve results, you need to create a so-called statement handle with:
       
   920 
       
   921     $mysql->query(q{
       
   922         SELECT id, message FROM foo
       
   923     });
       
   924     if ($mysql->has_selected_record) {
       
   925         my $a_record_iterator = $mysql->create_record_iterator;
       
   926         # ...
       
   927     }
       
   928 
       
   929 This Net::MySQL::RecordIterator object can be used for multiple purposes. First of all you can retreive a row of data:
       
   930 
       
   931     my $record = $a_record_iterator->each;
       
   932 
       
   933 The each() method takes out the reference result of one line at a time, and the return value is ARRAY reference.
       
   934 
       
   935 =head2 Net::MySQL API
       
   936 
       
   937 =over 4
       
   938 
       
   939 =item new(HASH)
       
   940 
       
   941     use Net::MySQL;
       
   942     use strict;
       
   943 
       
   944     my $mysql = Net::MySQL->new(
       
   945         unixsocket => $path_to_socket,
       
   946         hostname   => $host,
       
   947         database   => $database,
       
   948         user       => $user,
       
   949         password   => $password,
       
   950     );
       
   951 
       
   952 The constructor of Net::MySQL. Connection with MySQL daemon is established and the object is returned. Argument hash contains following parameters:
       
   953 
       
   954 =over 8
       
   955 
       
   956 =item unixsocket
       
   957 
       
   958 Path of the UNIX socket where MySQL daemon. default is F</tmp/mysql.sock>.
       
   959 Supposing I<hostname> is omitted, it will connect by I<UNIX Socket>.
       
   960 
       
   961 =item hostname
       
   962 
       
   963 Name of the host where MySQL daemon runs.
       
   964 Supposing I<hostname> is specified, it will connect by I<INET Socket>.
       
   965 
       
   966 =item port
       
   967 
       
   968 Port where MySQL daemon listens to. default is 3306.
       
   969 
       
   970 =item database
       
   971 
       
   972 Name of the database to connect.
       
   973 
       
   974 =item user / password
       
   975 
       
   976 Username and password for database authentication.
       
   977 
       
   978 =item timeout
       
   979 
       
   980 The waiting time which carries out a timeout when connection is overdue is specified.
       
   981 
       
   982 =item debug
       
   983 
       
   984 The exchanged packet will be outputted if a true value is given.
       
   985 
       
   986 =back
       
   987 
       
   988 
       
   989 =item create_database(DB_NAME)
       
   990 
       
   991 A create_DATABASE() method creates a database by the specified name.
       
   992 
       
   993     $mysql->create_database('example_db');
       
   994     die $mysql->get_error_message if $mysql->is_error;
       
   995 
       
   996 =item drop_database(DB_NAME)
       
   997 
       
   998 A drop_database() method deletes the database of the specified name.
       
   999 
       
  1000     $mysql->drop_database('example_db');
       
  1001     die $mysql->get_error_message if $mysql->is_error;
       
  1002 
       
  1003 =item query(SQL_STRING)
       
  1004 
       
  1005 A query() method transmits the specified SQL string to MySQL database, and obtains the response.
       
  1006 
       
  1007 =item create_record_iterator()
       
  1008 
       
  1009 When SELECT type SQL is specified, Net::MySQL::RecordIterator object which shows the reference result is returned.
       
  1010 
       
  1011     $mysql->query(q{SELECT * FROM table});
       
  1012     my $a_record_iterator = $mysql->create_recrod_iterator();
       
  1013 
       
  1014 Net::MySQL::RecordIterator object is applicable to acquisition of a reference result. See L<"/Net::SQL::RecordIterator API"> for more.
       
  1015 
       
  1016 =item get_affected_rows_length()
       
  1017 
       
  1018 returns the number of records finally influenced by specified SQL.
       
  1019 
       
  1020     my $affected_rows = $mysql->get_affected_rows_length;
       
  1021 
       
  1022 =item get_insert_id()
       
  1023 
       
  1024 MySQL has the ability to choose unique key values automatically. If this happened, the new ID will be stored in this attribute. 
       
  1025 
       
  1026 =item is_error()
       
  1027 
       
  1028 TRUE will be returned if the error has occurred.
       
  1029 
       
  1030 =item has_selected_record()
       
  1031 
       
  1032 TRUE will be returned if it has a reference result by SELECT.
       
  1033 
       
  1034 =item get_field_length()
       
  1035 
       
  1036 return the number of column.
       
  1037 
       
  1038 =item get_field_names()
       
  1039 
       
  1040 return column names by ARRAY.
       
  1041 
       
  1042 =item close()
       
  1043 
       
  1044 transmits an end message to MySQL daemon, and closes a socket.
       
  1045 
       
  1046 =back
       
  1047 
       
  1048 =head2 Net::MySQL::RecordIterator API
       
  1049 
       
  1050 Net::MySQL::RecordIterator object is generated by the query() method of Net::MySQL object. Thus it has no public constructor method.
       
  1051 
       
  1052 =over 4
       
  1053 
       
  1054 =item each()
       
  1055 
       
  1056 each() method takes out only one line from a result, and returns it as an ARRAY reference. C<undef> is returned when all the lines has been taken out.
       
  1057 
       
  1058     while (my $record = $a_record_iterator->each) {
       
  1059         printf "Column 1: %s Column 2: %s Collumn 3: %s\n",
       
  1060             $record->[0], $record->[1], $record->[2];
       
  1061     }
       
  1062 
       
  1063 =back
       
  1064 
       
  1065 =head1 SUPPORT OPERATING SYSTEM
       
  1066 
       
  1067 This module has been tested on these OSes.
       
  1068 
       
  1069 =over 4
       
  1070 
       
  1071 =item * MacOS 9.x
       
  1072 
       
  1073 with MacPerl5.6.1r.
       
  1074 
       
  1075 =item * MacOS X
       
  1076 
       
  1077 with perl5.6.0 build for darwin.
       
  1078 
       
  1079 =item * Windows2000
       
  1080 
       
  1081 with ActivePerl5.6.1 build631.
       
  1082 
       
  1083 =item * FreeBSD 3.4 and 4.x
       
  1084 
       
  1085 with perl5.6.1 build for i386-freebsd.
       
  1086 
       
  1087 with perl5.005_03 build for i386-freebsd.
       
  1088 
       
  1089 =item * Linux
       
  1090 
       
  1091 with perl 5.005_03 built for ppc-linux.
       
  1092 
       
  1093 with perl 5.6.0 bult for i386-linux.
       
  1094 
       
  1095 =item * Solaris 2.6 (SPARC)
       
  1096 
       
  1097 with perl 5.6.1 built for sun4-solaris.
       
  1098 
       
  1099 with perl 5.004_04 built for sun4-solaris.
       
  1100 
       
  1101 Can use on Solaris2.6 with perl5.004_04, although I<make test> is failure.
       
  1102 
       
  1103 =back
       
  1104 
       
  1105 This list is the environment which I can use by the test usually. Net::MySQL will operate  also in much environment which is not in a list.
       
  1106 
       
  1107 I believe this module can work with whatever perls which has B<IO::Socket>. I'll be glad if you give me a report of successful installation of this module on I<rare> OSes.
       
  1108 
       
  1109 =head1 SEE ALSO
       
  1110 
       
  1111 L<libmysql>, L<IO::Socket>
       
  1112 
       
  1113 =head1 AUTHOR
       
  1114 
       
  1115 Hiroyuki OYAMA E<lt>oyama@module.jpE<gt>
       
  1116 
       
  1117 =head1 COPYRIGHT AND LICENCE
       
  1118 
       
  1119 Copyright (C) 2002 Hiroyuki OYAMA. Japan. All rights reserved.
       
  1120 
       
  1121 This library is free software; you can redistribute it and/or modify
       
  1122 it under the same terms as Perl itself. 
       
  1123 
       
  1124 =cut