# IO::Obex - a Perl class to talk to Obex devices
	#
	# editions Systeme D, 2007
	# This program is public domain.

	# To do, 4th April:
	#Ê- some confusion about continue/repeated requests
	#   (should probably send a 'success' or something after last one)
	# - save file
	# - lots more stuff!

	
	package IO::Obex;

BEGIN {

	require Device::SerialPort;
	import  Device::SerialPort;

	%identifiers=(0xC0 => 'count',
				  0x01 => 'name',
				  0x42 => 'type',
				  0xC3 => 'length',
				  0x44 => 'time',
				  0xC4 => 'time_long',
				  0x05 => 'description',
				  0x46 => 'target',
				  0x47 => 'http',
				  0x48 => 'body',
				  0x49 => 'end_of_body',
				  0x4A => 'who',
				  0xCB => 'connection_id',
				  0x4C => 'parameters',
				  0x4D => 'challenge',
				  0x4E => 'response',
				  0x4F => 'object');
	%headernames=reverse %identifiers;
	
}
	
	# new		  - create new communication
	#				device->'/dev/tty.usbserial'
	#				model->'siemens'
	
	sub new {
		my ($proto,%aOpt) = @_;				# Get reference to object
		my $self=bless \%aOpt;				# Instance $class object

		# Initialise serial port

		$self->ph(new Device::SerialPort($self->{'device'})) || die "Can't open port: $!\n";
		$self->ph->baudrate(19200);
		$self->ph->databits(8);
		$self->ph->stopbits(1);
		$self->ph->parity("none");

		$self->ph->buffers(10000,10000);
		$self->ph->handshake("none");
		$self->ph->read_char_time(0);

		$self->ph->write_settings;
		$self->ph->purge_all;

		# Send 'start Obex' command
		if ($self->{'model'}=~/^siemens/i) {
			$self->_phone_write("+++");
			sleep(1.1);
			$self->_phone_write_command("ATQ0 V1 E0\r");
			$self->_phone_write_command("AT^SQWE=0\r");
			$self->_phone_write_command("AT^SQWE=3\r");
		} elsif ($self->{'model'}=~/^motorola/i) {
			$self->_phone_write("+++");
			sleep(1.1);
			$self->_phone_write_command("ATQ0 V1 E0\r");
			$self->_phone_write("AT+MODE=22\r");
		} elsif ($self->{'model'}=~/^sony/i) {
			$self->_phone_write("+++");
			sleep(1.1);
			$self->_phone_write_command("ATQ0 V1 E0\r");
			$self->_phone_write("AT*EOBEX\r");
		}
		return $self;
	}


	# connect	  - new Obex connection

	sub connect {
		my $self = shift;
		$self->_phone_write(chr(0x80).
							chr(0x00).chr(0x1A).
							chr(0x10).
							chr(0x00).
							chr(0x04).chr(0x00).
							chr(0x46).chr(0x00).chr(0x13).
							chr(0xF9).chr(0xEC).chr(0x7B).chr(0xC4).
							chr(0x95).chr(0x3C).
							chr(0x11).chr(0xd2).
							chr(0x98).chr(0x4E).
							chr(0x52).chr(0x54).chr(0x00).chr(0xDC).chr(0x9E).chr(0x09));
		my $response=$self->_phone_read_packet();
		if (substr($response,0,1) ne chr(0xA0)) { die "Unexpected response to Obex connect\n"; }
print "Connected with "; hexdump($response);
		$self->{'maxpacket'}=ord(substr($response,5,1))*256+
							 ord(substr($response,6,1));
$self->{'maxpacket'}=512;
	}

	# put		  - send data to device
	#				name->'', type->'', description->'', time->'',
	#				target->'', http->'', who->'', parameters->%,
	#				data->''

	sub put {
		my ($self,%options)=@_;
		my @headers=();
		my @order=('target','connection_id','count','name','type','length','time','http',
				   'who','data'); # order of sending is important
		
		foreach my $id (@order) {
			if (exists $options{$id}) { push @headers,$self->_header($id,$options{$id}); }
		}
		$self->_obex_dialogue(chr(0x02),'',@headers);
	}

	# fetch('')   - fetch file
	
	sub fetch {
		my $self=shift;
		my $name=shift;
		my @headers=();
		
		push @headers,$self->_header('name',$name);
		$self->_obex_dialogue(chr(0x03),'',@headers);
	}

	# set_path('') - change directory
	
	sub set_path {
		my $self=shift;
		my $name=shift;
		my @headers=();

		push @headers,$self->_header('name',$name);
		$self->_obex_dialogue(chr(0x85),chr(0).chr(0),@headers);
	}
	
	# get_capability-request capabilities

	sub get_capability {
		my $self=shift;
		my $name=shift;
		my @headers=();

		push @headers,$self->_header('type','x-obex/capability'.chr(0));
		$self->_obex_dialogue(chr(0x03),'',@headers);
	}

	# get_directory- request folder listing
	
	sub get_directory {
		my $self=shift;
		my @headers=();

		push @headers,$self->_header('type','x-obex/folder-listing'.chr(0));
		$self->_obex_dialogue(chr(0x03),'',@headers);
	}

	# disconnect  - close Obex connection
	#				needs to call _parse_headers routine

	sub disconnect {
		my $self = shift;
		$self->_phone_write(chr(0x81).
							chr(0x00).chr(0x03));
		hexdump($self->_phone_read_packet());
	}
	
	# report	  - debug
	
	sub report {
		my $self = shift;
		print "Device type is $self->{'device'}\n";
		print "$self->ph\n";
	}

	sub hexdump {
		my $a=shift; my $c;
		foreach $c (split(//,$a)) {
			printf ("%02X ",ord $c);
		}
		print "\n";
	}


	# =================================================================
	# Obex format subroutines
	
	sub _parse_headers {
		my $self=shift;
		my $text=shift;
	}
	
	# =================================================================
	# Utility subroutines
	
	# _obex_dialogue	   - request/response dialogue
	#						 (opcode,extra arguments,array of headers)
	
	sub _obex_dialogue {
print "Entering dialogue\n";
		my $self=shift;
		my $opcode=shift;
		my $data=shift;
		my @headers=@_;
		my $response;
		$self->_clear_parameters;
		while (@headers) {
print "Processing a header\n";
			if (length($data)+length($headers[0])+3>$self->{'maxpacket'}) {
print "Writing packet\n";
				$self->_phone_write_packet($opcode,$data);
print "Reading response\n";
				$response=$self->_phone_read_packet;
print "Response is "; hexdump($response);
print "Parsing response\n";
				$self->_parse_packet($response);
				$data='';
			}
			$data.=shift @headers;
		}

		# Send final packet
print "Sending final packet\n";
		$opcode|=chr(0x80);							# Perl is the new Z80
		$self->_phone_write_packet($opcode,$data);

		# Get any remaining packets
		my $finished=0;
		while (!$finished) {
print "Reading response\n";
			$response=$self->_phone_read_packet;
print "Response is "; hexdump($response);
print "Parsing response\n";
			$self->_parse_packet($response);
			if ((ord(substr($response,0,1)) & 0x7F)==0x10) {
print "Sending continue packet\n";
				$self->_phone_write_packet($opcode,'');	#Êcontinue
			} else { $finished=1; }
		}
	}
	
	# _clear_parameters		- clear all Obex parameters from object
	
	sub _clear_parameters {
		my $self=shift;
		foreach my $a (values %identifiers) { delete $self->{$a}; }
		delete $self->{'data'};
	}

	# _parse_packet			- set headers according to received packet
	
	sub _parse_packet {
		my $self=shift;
		my $response=shift;
		my $id; my $a;
		
		my $opcode=ord(substr($response,0,1));
		if (($opcode & 0x7f)>0x22) { die "Device sent error response code 0x".sprintf("%02X",$opcode); }
		
		# Do something here with opcode
		
		$response=substr($response,3);
		while ($response ne '') {
			$idnum=ord(substr($response,0,1));
			if (exists $identifiers{$idnum}) { $id=$identifiers{$idnum}; }
										else { die "Don't recognise header id 0x".sprintf("%02X",$id); }

			if (($id eq 'body') or ($id eq 'end_of_body')) {
				unless (exists $self->{'data'}) { $self->{'data'}=''; }
				$a=unpack('n',substr($response,1,2));
				$self->{'data'}.=substr($response,3,$a-3);
				$response=substr($response,$a);

			} elsif ($idnum>=0xC0) {
				$self->{$id}=unpack('N',substr($response,1,4));
				$response=substr($response,5);

			} elsif ($idnum>=0x80) {
				$self->{$id}=ord(substr($response,1,1));
				$response=substr($response,2);

			} elsif ($idnum>=0x40) {
				$a=unpack('n',substr($response,1,2));
				$self->{$id}=substr($response,3,$a-3);
				$response=substr($response,$a);

			} else {
				$a=unpack('n',substr($response,1,2));
				$self->{$id}=_from_unicode(substr($response,3,$a-5));
				$response=substr($response,$a);
			}
		}
	}
	
	sub _header {
		my $self=shift;
		my $id=shift;
		my $arg=shift;
		
		if ($id eq 'data') {
			my @datas=();
			my $maxlen=$self->{'maxpacket'}-10;
			while (length($arg)>$maxlen) {
				push @datas,chr(0x48).pack('n',$maxlen+3).substr($arg,0,$maxlen);
				$arg=substr($arg,$maxlen);
			}
			push @datas,chr(0x49).pack('n',length($arg)+3).$arg;
			return @datas;
		} else {
			if (exists $headernames{$id}) { $idnum=$headernames{$id}; }
									 else { die "Don't recognise header type $id"; }
			if ($idnum>=0xC0) {
				return chr($idnum).pack('N',$arg);
			} elsif ($idnum>=0x80) {
				return chr($idnum).chr($arg);
			} elsif ($idnum>=0x40) {
				return chr($idnum).pack('n',length($arg)+3).$arg;
			} else {
				return chr($idnum).pack('n',length($arg)*2+5)._to_unicode_null($arg);
			}
		}
	}
	
	# _to_unicode_null		- convert string to null-terminated 'Unicode'
	#						  needs to cope with real Unicode!
	# _from_unicode			- convert string back from 'Unicode'
	
	sub _to_unicode_null { return pack('n*',unpack('C*',$_[0].chr(0))); }
	sub _from_unicode	 { return pack('C*',unpack('n*',$_[0])); }

	# _phone_write		    - write string to phone
	
	sub _phone_write {
		my $self=shift;
		my $text=shift;
		$self->ph->write($text);
	}


	# _phone_write_packet   - write string as packet
	#						  (opcode,data)
	
	sub _phone_write_packet {
		my $self=shift;
		my $opcode=shift;
		my $text=shift;
print "Sending "; hexdump $opcode.pack('n',length($text)+3).$text;
		$self->_phone_write($opcode.pack('n',length($text)+3).$text);
	}

	# _phone_write_command  - write string,
	#						  wait for \r-terminated response

	sub _phone_write_command {
		my $self=shift;
		my $text=shift;
		$self->ph->write($text);
		return $self->_phone_read_until(qr/\r$/);
	}

	# _phone_read_until     - read string until regex is matched

	sub _phone_read_until {
		my $self=shift;
		my $re=shift;
		my $timeout=30;
		my $string="";
		$self->ph->read_const_time(200);
		while ($timeout>0) {
			my ($count,$text)=$self->ph->read(255);
			if ($count>0) { $string.=$text;
							if ($string=~/$re/) { return $string; } 
							$timeout=30; }
					 else { $timeout--; }
		}
		if ($timeout==0) { return undef; }
					else { return $string; }
	}

	# _phone_read_packet - read string with length in bytes 2/3

	sub _phone_read_packet {
		my $self=shift;
		my $timeout=30;
		my $string="";
		my $packlen;
		
		$self->ph->read_const_time(200);
		while ($timeout>0) {
			my ($count,$text)=$self->ph->read(255);
			if ($count>0) { $string.=$text; $timeout=30; }
			if (length($string)>2) {
				$packlen=ord(substr($string,1,1))*256+
						 ord(substr($string,2,1));
				if ($packlen==length($string)) { return $string; }
			}
		}
		return undef;
	}

	# ph				  - accesses phone object

	sub ph {
		my $self = shift();
		@_ ? $self->{'_phone'} = shift()
		   : $self->{'_phone'};
	}
	

	1;