view release on metacpan or  search on metacpan

lib/AnyEvent/MySQL/Imp.pm  view on Meta::CPAN

=head2 ($errno, $sqlstate, $message) = parse_error($data(modified))
=cut
sub parse_error {
    if( substr($_[0], 0, 1) eq "\xFF" ) {
        if( wantarray ) {
            substr($_[0], 0, 1, '');
            return (
                take_num($_[0], 2),
                ( substr($_[0], 0, 1) eq '#' ?
                  ( substr($_[0], 1, 5), substr($_[0], 6) ) :
                  ( '', $_[0] )
                )
            );
        }
        else {
            return 1;
        }
    }
    else {
        return;
    }
}

## ($field_count, $extra) = parse_result_set_header($data(modified))
#sub parse_result_set_header {
#    if( $substr($_[0], 0, 1) 
#}

=head2 recv_packet($hd, $cb->($packet))
=cut
sub recv_packet {
    my $cb = pop;
    my($hd) = @_;
    if( $hd ) {
        $hd->push_read( chunk => 4, sub {
            my $len = unpack("V", $_[1]);
            my $num = $len >> 24;
            $len &= 0xFFFFFF;
            print "pack_len=$len, pack_num=$num\n" if DEV;
            $_[0]->unshift_read( chunk => $len, sub {
                $cb->($_[1]);
            } );
        } );
    }
}

=head2 skip_until_eof($hd, $cb->())
=cut
sub skip_until_eof {
    my($hd, $cb) = @_;
    recv_packet($hd, sub {
        if( substr($_[0], 0, 1) eq "\xFE" ) {
            $cb->();
        }
        else {
            skip_until_eof($hd, $cb);
        }
    });
}

=head2 send_packet($hd, $packet_num, $packet_frag1, $pack_frag2, ...)
=cut
sub send_packet {
    return if !$_[0];
    local $_[0] = $_[0];
    my $len = reduce { $a + length($b) } 0, @_[2..$#_];
    $_[0]->push_write(substr(pack('V', $len), 0, 3) . chr($_[1]) . join('', @_[2..$#_]));
}

=head2 _recv_field($hd, \@field)
=cut
sub _recv_field {
    warn "get field." if DEV;
    my $field = $_[1];
    recv_packet($_[0], sub {
        warn "got field!" if DEV;
        push @$field, [
            take_lcs($_[0]), take_lcs($_[0]), take_lcs($_[0]),
            take_lcs($_[0]), take_lcs($_[0]), take_lcs($_[0]),
            take_filler($_[0], 1),
            take_num($_[0], 2),
            take_num($_[0], 4),
            take_num($_[0], 1),
            take_num($_[0], 2),
            take_num($_[0], 1),
            take_filler($_[0], 2),
            take_lcb($_[0]),
        ];
    });
}

=head2 recv_response($hd, %opt, $cb->(TYPE, data...))
  RES_OK, $affected_rows, $insert_id, $server_status, $warning_count, $message
  RES_ERROR, $errno, $sqlstate, $message
  RES_RESULT, \@field, \@row
   $field[$i] = [$catalog, $db, $table, $org_table, $name, $org_name, $charsetnr, $length, $type, $flags, $decimals, $default]
   $row[$i] = [$field, $field, $field, ...]
  RES_PREPARE, $stmt_id, \@param, \@column, $warning_count
   $param[$i] = [$catalog, $db, $table, $org_table, $name, $org_name, $charsetnr, $length, $type, $flags, $decimals, $default]
   $column[$i] = [$catalog, $db, $table, $org_table, $name, $org_name, $charsetnr, $length, $type, $flags, $decimals, $default]
 opt:
  prepare (set to truthy to recv prepare_ok)
=cut
sub recv_response {
    my $cb = ref($_[-1]) eq 'CODE' ? pop : sub {};
    my($hd, %opt) = @_;

    if( DEV ) {
        my $cb0 = $cb;
        $cb = sub {
            use Data::Dumper;
            warn "recv_response: ".Dumper(\@_);
            &$cb0;
        };
    }

    recv_packet($hd, sub {
        my $head = substr($_[0], 0, 1);
        if( $head eq "\x00" ) { # OK
            substr($_[0], 0, 1, '');
            if( $opt{prepare} ) {