|
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 |