File Coverage

blib/lib/Net/OBEX.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package Net::OBEX;

use warnings;
use strict;

our $VERSION = '1.001001'; # VERSION

use Carp;
use Socket::Class;
use IO::Handle;
use Net::OBEX::Packet::Request;
use Net::OBEX::Response;
use Net::OBEX::Packet::Headers;
use Devel::TakeHashArgs;

use base qw(Class::Data::Accessor);

__PACKAGE__->mk_classaccessors( qw(
        sock
        error
        mtu
        success
        code
        status
        connection_id
        obj_res
        obj_head
        obj_req
        response
    )
);

sub new {
    my $class = shift;
    my $self = bless {}, $class;

    $self->obj_head( Net::OBEX::Packet::Headers->new );
    $self->obj_req(  Net::OBEX::Packet::Request->new );
    $self->obj_res(  Net::OBEX::Response->new        );

    return $self;
}

sub connect {
    my $self = shift;
    $self->$_(undef) for qw(success code status mtu);
    get_args_as_hash(\@_, \ my %args, {
            version => "\x10",
            mtu     => 4096,
            domain  => 'bluetooth',
            type    => 'stream',
            proto   => 'rfcomm',
            headers => [],
        },
        [ qw(address port) ],
    )
    or croak $@;

    my $sock = Socket::Class->new(
        'domain'        => $args{domain},
        'type'          => $args{type},
        'proto'         => $args{proto},
        'remote_addr'   => $args{address},
        'remote_port'   => $args{port},
    ) or return $self->_set_error(
        'Failed to create socket: ' . Socket::Class->error
    );

    $self->sock( $sock );

     defined $args{target}
        and push @{ $args{headers} },
             $self->obj_head->make( target => pack 'H*', $args{target} );

    my $connect_packet = $self->obj_req->make(
        packet  => 'connect',
        mtu     => $args{mtu},
        version => $args{version},
        headers => $args{headers},
    );
    $sock->send( $connect_packet );

    my $obj_response = $self->obj_res;
    my $response_ref = $obj_response->parse_sock( $sock, 'connect' )
        or return $self->_set_error( $obj_response->error );

    # make and save connection ID header.. we will need it in every
    # packet
    if ( defined (my $id = $response_ref->{headers}{connection_id}) ) {
        $self->connection_id(
            $self->obj_head->make( connection_id => $id )
        );
    }

    # save other party's MTU
    $self->mtu( $response_ref->{info}{mtu} || 255 );

    $response_ref->{info}{response_code} == 200
        and $self->success(1);

    $self->code( $response_ref->{info}{response_code} );
    $self->status( $response_ref->{info}{response_code_meaning} );

    return $self->response( $response_ref );
}

sub disconnect {
    my $self = shift;
    get_args_as_hash( \@_, \ my %args, { headers => [] } )
        or croak $@;

    # Connection ID must be the first header if it's present
    $self->_add_connection_id( $args{headers} );

    defined $args{description}
        and push @{ $args{headers} },
            $self->head->make( description => $args{description} );

    my $disconnect_packet = $self->obj_req->make(
        packet  => 'disconnect',
        headers => $args{headers},
    );

    my $sock = $self->sock;
    $sock->send( $disconnect_packet );

    my $obj_response = $self->obj_res;
    my $response_ref = $obj_response->parse_sock( $sock )
        or return $self->_set_error( $obj_response->error );

    return $self->response( $response_ref );
}

sub set_path {
    my $self = shift;
    $self->$_(undef) for qw(success code status);
    get_args_as_hash( \@_, \ my %args, { headers => [] } )
        or croak $@;

    # Connection ID must be the first header if it's present
    $self->_add_connection_id( $args{headers} );

    # the path to setpath to should go into Name header
    defined $args{path}
        and push @{ $args{headers} },
            $self->obj_head->make( name => $args{path} );

    my $set_path_packet = $self->obj_req->make(
        packet  => 'setpath',
        headers => $args{headers},
        (defined $args{do_up    } ? ( do_up     => $args{do_up    } ) : ()),
        (defined $args{no_create} ? ( no_create => $args{no_create} ) : ()),
    );

    my $sock = $self->sock;
    $sock->send( $set_path_packet );

    my $obj_response = $self->obj_res;
    my $response_ref = $obj_response->parse_sock( $sock )
        or return $self->_set_error( $obj_response->error );

    $response_ref->{info}{response_code} == 200
        and $self->success(1);

    $self->code( $response_ref->{info}{response_code} );
    $self->status( $response_ref->{info}{response_code_meaning} );

    return $self->response( $response_ref );
}

sub get {
    my $self = shift;
    $self->$_(undef) for qw(success code status);
    get_args_as_hash( \@_, \ my %args, { is_final => 1, headers => [] } )
        or croak $@;

    # Connection ID must be the first header if it's present
    $self->_add_connection_id( $args{headers} );

    my $head = $self->obj_head;
    for ( qw(type name ) ) {
        defined $args{ $_ }
            and push @{ $args{headers} }, $head->make( $_ => $args{ $_ } );
    }

    my $obj_request  = $self->obj_req;
    my $packet = $obj_request->make(
        packet   => 'get',
        is_final => $args{is_final},
        headers  => $args{headers},
    );

    my $sock = $self->sock;
    $sock->send( $packet );

    my @responses;
    my $obj_response = $self->obj_res;
    my $full_body = '';
    my $first_response_code;
    my $first_response_code_meaning;
    CONTINIUE_GET: {
        my $response_ref = $obj_response->parse_sock( $sock )
            or return $self->_set_error( $obj_response->error );

        unless ( defined $first_response_code ) {
            ( $first_response_code, $first_response_code_meaning )
            = @{ $response_ref->{info} }{
                qw(response_code  response_code_meaning)
            }
        }

        if ( exists $response_ref->{headers}{body}
            or exists $response_ref->{headers}{end_of_body}
        ) {
            my $body = exists $response_ref->{headers}{end_of_body}
                     ? $response_ref->{headers}{end_of_body}
                     : $response_ref->{headers}{body};

            if ( exists $args{file} ) {
                $args{file}->print($body);
            }
            else {
                $full_body .= $body;
                push @responses, $response_ref;
            }
        }

        # if server asks to "Continue"
        if ( $response_ref->{info}{response_code} == 100
            and not $args{no_continue}
        ) {
            $sock->send(
                $obj_request->make( packet => 'get', is_final => 1 )
            );

            redo CONTINIUE_GET;
        }

        unless (
            $response_ref->{info}{response_code} == 200
            or $response_ref->{info}{response_code} == 100
        ) {
            $self->status(
                $response_ref->{info}{response_code_meaning}
            );
            $self->code( $response_ref->{info}{response_code} );
            $response_ref->{is_error} = 1;
            return $response_ref;
        }
    } # CONTINUTE_GET block end

    $first_response_code == 200 or $first_response_code == 100
        and $self->success(1);

    $self->code( $first_response_code );
    $self->status( $first_response_code_meaning );

    return $self->response( {
            body            => $full_body,
            responses       => \@responses,
            response_code   => $first_response_code,
            response_code_meaning => $first_response_code_meaning,
        }
    );
}

sub put {
    my $self = shift;
    $self->$_(undef) for qw(success code status);
    get_args_as_hash( \@_, \ my %args, {
            headers         => [],
            body_in_first   => 0,
            no_name         => 0,
        },
        [ 'what' ],
    ) or croak $@;

    # Connection ID must be the first header if it's present
    $self->_add_connection_id( $args{headers} );

    my $head = $self->obj_head;
    for ( qw(length time name type) ) {
        exists $args{ $_ }
            and push @{ $args{headers} }, $head->make( $_, $args{$_} );
    }

    unless ( $args{no_name} or exists $args{name} ) {
        push @{ $args{headers} }, $head->make( name => $args{what} );
    }

    open my $fh, '<', $args{what}
        or return $self->_set_error("Failed to open $args{what} ($!)");

    binmode $fh;

    my $mtu = $self->mtu - 2 - length join '', @{ $args{headers} };

    my $sock = $self->sock;
    my $obj_res = $self->obj_res;
    my $obj_req = $self->obj_req;
    unless ( $args{body_in_first} ) {
        my $packet = $obj_req->make(
            packet  => 'put',
            headers => $args{headers},
        );

        $sock->send( $packet );
        my $response_ref = $obj_res->parse_sock( $sock )
            or return $self->_set_error(
                'Socket error: ' . $obj_res->error
            );

        unless (
            $response_ref->{info}{response_code} == 200
            or $response_ref->{info}{response_code} == 100
        ) {
            $self->status(
                $response_ref->{info}{response_code_meaning}
            );
            $self->code( $response_ref->{info}{response_code} );
            return $response_ref;
        }
    }

    {
        local $/ = \$mtu;
        while ( <$fh> ) {

            my $packet = $obj_req->make(
                packet  => 'put',
                headers => [
                    ( $args{body_in_first} ? () : @{ $args{headers} } ),
                    $head->make( body => $_ ),
                ],
            );
            $sock->send( $packet );
            my $response_ref = $obj_res->parse_sock( $sock )
                or return $self->_set_error(
                    'Socket error: ' . $obj_res->error
                );

            unless (
                $response_ref->{info}{response_code} == 200
                or $response_ref->{info}{response_code} == 100
            ) {
                $self->status(
                    $response_ref->{info}{response_code_meaning}
                );
                $self->code( $response_ref->{info}{response_code} );
                $response_ref->{is_error} = 1;
                return $response_ref;
            }
        }
        my $packet = $obj_req->make(
            packet   => 'put',
            is_final => 1,
            headers => [
                @{ $args{headers} },
                $head->make( end_of_body => '' ),
            ],
        );

        $sock->send( $packet );
        my $response_ref = $obj_res->parse_sock( $sock );
        $response_ref->{info}{response_code} == 200
            and $self->success(1);

        $self->code( $response_ref->{info}{response_code} );
        $self->status( $response_ref->{info}{response_code_meaning} );
        return $self->response( $response_ref );
    }
}

sub close {
    my ( $self, $description ) = @_;

    my $sock = $self->sock;
    eval {
        my $disconnect_packet = $self->obj_req->make(
            packet  => 'disconnect',
            headers => [
                defined $description
                ? $self->obj_head->make( description => $description )
                : ()
            ],
        );

        $sock->send( $disconnect_packet );
    };
    $sock->free();

    return 1;
}

sub _add_connection_id {
    my ( $self, $headers_ref ) = @_;
    if ( defined ( my $id = $self->connection_id ) ) {
        unshift @$headers_ref, $id;
    }
}

sub _set_error {
    my ( $self, $error ) = @_;
    $self->error( $error );
    return;
}

1;
__END__