home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / xampp / xampp-perl-addon-1.4.9-installer.exe / MySQL.pm < prev    next >
Encoding:
Perl POD Document  |  2003-01-27  |  22.6 KB  |  1,016 lines

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