Data::Sofu::Binary::Bin0200 - Driver for Sofu Binary version 0.2.0.0

	require Data::Sofu::Binary;
	$bsofu = Data::Sofu::Binary->new("000_002_000_000"); Taking this driver;
	#You can call it directly:
	require Data::Sofu::Binary::Bin0200;
	$bsofu = Data::Sofu::Binary::Bin0200->new(); #The same

###############################################################################
#List.pm
#Last Change: 2008-02-07
#Copyright (c) 2008 Marc-Seabstian "Maluku" Lucksch
#Version 0.28
####################
#This file is part of the sofu.pm project, a parser library for an all-purpose
#ASCII file format. More information can be found on the project web site
#at http://sofu.sourceforge.net/ .
#
#sofu.pm is published under the terms of the MIT license, which basically means
#"Do with it whatever you want". For more information, see the license.txt
#file that should be enclosed with libsofu distributions. A copy of the license
#is (at the time of this writing) also available at
#http://www.opensource.org/licenses/mit-license.php .
###############################################################################

package Data::Sofu::Binary::Bin0200;
use strict;
use warnings;
use bytes;

our $VERSION="0.29";
#We are really going to need these modules:
use Encode;
use Carp qw/confess/;
require Data::Sofu;
use base qw/Data::Sofu::Binary/;

#$SIG{__WARN__}=sub {	confess @_;};

sub new {
	my $class=shift;
	my $self={};
	bless $self,$class;
	$self->{OBJECT}=0;
	$self->{COMMENTS}=[];
	$self->{SUPPORTED}={"000_002_000_000"=>1};
	return $self;
}

sub encoding { #Switches the Encoding
	my $self=shift;
	my $id=shift;
	my @encoding = qw/UTF-8 UTF-7 UTF-16 UTF-16BE UTF-16LE UTF-32 UTF-32BE UTF-32LE null null ascii cp1252 latin1 Latin9 Latin10/;
	my %encoding;
	@encoding{map {lc $_} @encoding} = (0 .. 12);
	if (exists $encoding{lc $id}) {
		$self->{EncID}=$encoding{lc $id};
		return $self->{Encoding}=$encoding[$self->{EncID}];
	}
	if ($encoding[int $id]) {
		$self->{EncID}=$id;
		return $self->{Encoding}=$encoding[$id];
	}
	$self->die("Unknown Encoding");
	
}

sub byteorder {
	my $self=shift;
	my $bo=shift;
	if ($bo =~ m/le/i) { #little Endian
		$self->{SHORT}="v";
		$self->{LONG}="V";
		return 0;
	}
	if ($bo =~ m/be/i) { #BIG Endian
		$self->{SHORT}="n";
		$self->{LONG}="N";
		return 0;
	}
	if ($bo=~m/7/) { #7-Bit Mode
		$self->{SHORT}=undef;
		$self->{LONG}=undef;
		$self->encoding(1);
		return 1;
	}
	if ($bo=~m/Force/i) { #7-Bit Mode without UTF-7 encoding
		$self->{SHORT}=undef;
		$self->{LONG}=undef;
		#$self->encoding(1);
		return 0;
	}
	$self->{SHORT}="S";
	$self->{LONG}="L";
	return 0;

}

sub bom {
	my $self=shift;
	my $bo=shift;
	if ($bo==1) { #Machine Order
		$self->{SHORT}="S";
		$self->{LONG}="L";
		return 0;
	}
	if ($bo==256) { #Wrong Order
		if (1 == CORE::unpack('S',pack('v',1))) {# We are little Endian
			$self->{SHORT}="n";
			$self->{LONG}="N";
		}
		else {
			$self->{SHORT}="v";
			$self->{LONG}="V";
		}
		return 0;
	}
	if ($bo==0) { #7-Bit Mode
		$self->{SHORT}=undef;
		$self->{LONG}=undef;
		$self->encoding(1);
		return 1;
	}
	$self->die("Unknown Byteorder: $bo, can't continue");
	return 0;

}

sub packShort {
	my $self=shift;
	my $i=shift;
	$self->die("Short too large: $i") if $i > 65535;
	return pack $self->{SHORT},$i if $self->{SHORT};
	$self->die("Can't pack that Short in 7-Bit, too large: $i") if $i > 16383;
	return pack ("CC",($i&0x7F),($i&0x3F80));
}

sub packLong {
	my $self=shift;
	my $i=shift;
	$self->die("Long too large: $i") if $i > 4294967295;
	return pack $self->{LONG},$i if $self->{LONG};
	$self->die("Can't pack that Long in 7-Bit, too large: $i") if $i > 268435455;
	return pack ("CCCC",($i&0x7F),(($i&0x3F80) >> 7),(($i&0x1FC000) >> 14),(($i&0xFE00000) >> 21));
}

sub packendian {
	my $self=shift;
	if ($self->{SHORT}) {
		return $self->packShort(1);
	}
	return pack("S",0);
}

sub packversion {
	my $self=shift;
	return pack("CCCC",0,2,0,0);
}

sub packencoding {
	my $self=shift;
	return pack("C",$self->{EncID});
}

sub getType {
	my $self=shift;
	my $type = $self->get(1);
	$self->die ("Unexpected End of File") unless $type;
	if ($type eq "S") {
		my $str = $self->get(3);
		$self->die("Incomplete Sofu-Mark") if not $str or $str ne "ofu";
		$type = $self->get(1);
	}
	$self->die("No Type found") unless defined $type;
	$type=CORE::unpack("C",$type);
	$self->die("Unknown Type: $type") if $type > 4;
	return $type;
}

sub objectprocess {
	my $self=shift;
	$self->{Ref}->{""} = $self->{Ref}->{"->"} = $self->{Ref}->{"="};
	foreach my $e (@{$$self{References}}) {
		next if $e->valid();
		my $target = $e->follow()."";
		$target=~s/^@//;
		$target="->".$target if $target and $target !~ m/^->/;
		$e->dangle($self->{Ref}->{$target}) if $self->{Ref}->{$target};
	}
}

sub postprocess {
	my $self=shift;
	$self->{Ref}->{""} = $self->{Ref}->{"->"} = $self->{Ref}->{"="};
	foreach my $e (@{$$self{References}}) {
		#next;
		#print $$e;
		my $target = $$$e;
		$target=~s/^@//;
		$target="->".$target if $target and $target !~ m/^->/;
		$$e = undef;
		$$e = $self->{Ref}->{$target} if $self->{Ref}->{$target};
	}
}

sub getLong {
	my $self=shift;
	my $i=shift;
	return undef unless defined $i;
	return CORE::unpack($self->{LONG},$i) if $self->{LONG};
	my @i = CORE::unpack("CCCC",$i);
	#print join(", ",@i),"\n";
	return( (($i[0] & 0x7F) | (($i[1] & 0x7F) << 7)  | (($i[2] & 0x7F) << 14)  | (($i[3] & 0x7F) << 21)) );
}

sub getText {
	my $self=shift;
	my $len=$self->getLong($self->get(4));
	return undef unless defined $len;
	return "" if $len == 0;
	my $text = $self->get($len);
	return Encode::decode($self->{Encoding},$text,Encode::FB_CROAK);
	
}

sub getComment {
	my $self=shift;
	my $tree=shift;
	my $t = $self->getText();
	$self->die("Can't get Comment, EOF!") unless defined $t;
	return if $t eq "";
	if (ref $tree) {
		$tree->setComment([split /\n/,$t]);
	}
	else {
		$self->{COMMENTS}->{$tree}=[split /\n/,$t];
	}
	
}

sub unpackUndef {
	my $self=shift;
	my $tree=shift;
	$self->getComment($tree);
	return undef;

}

sub unpackScalar {
	my $self=shift;
	my $tree=shift;
	$self->getComment($tree);
	return $self->getText();

}

sub unpackRef {
	my $self=shift;
	my $tree=shift;
	$self->getComment($tree);
	my $x = $self->getText();
	return \$x;

}

sub unpackHash {
	my $self=shift;
	my $tree=shift;
	my %result=();
	$self->getComment($tree);
	my $len=$self->getLong($self->get(4));
	$self->die("Error while reading maplength, maybe EOF") unless defined $len;
	return {} if $len == 0;
	keys(%result) = $len; #Presetting the Hashsize
	for (my $i = 0;$i < $len;$i++) {
		my $key = $self->getText();
		$self->die("Error while reading key, maybe EOF") unless defined $key;
		my $kkey = Data::Sofu::Sofukeyescape($key);
		my $type = $self->getType();
		$result{$key} = $self->unpackType($type,"$tree->$kkey");
		$self->{Ref}->{"$tree->$kkey"}=$result{$key};
		push @{$self->{References}},\$result{$key} if ($type == 4);
	}
	return \%result;
	
}

sub unpackArray {
	my $self=shift;
	my $tree=shift;
	my @result=();
	$self->getComment($tree);
	my $len=$self->getLong($self->get(4));
	$self->die("Error while reading listlength, maybe EOF") unless defined $len;
	return {} if $len == 0;
	#die $len,"\n";
	$#result = $len-1; #Grow the Array :)
	for (my $i = 0;$i < $len;$i++) {
		my $type = $self->getType();
		$result[$i] = $self->unpackType($type,"$tree->$i");
		$self->{Ref}->{"$tree->$i"}=$result[$i];
		push @{$self->{References}},\$result[$i] if ($type == 4);
	}
	return \@result;
	
}

sub unpackType {
	my $self=shift;
	my $type=shift;
	my $tree=shift;
	if ($type == 0) {
		return $self->unpackUndef($tree);
	}
	elsif ($type == 1) {
		return $self->unpackScalar($tree);
	}
	elsif ($type == 2) {
		return $self->unpackArray($tree);
	}
	elsif ($type == 3) {
		return $self->unpackHash($tree);
	}
	elsif ($type == 4) {
		return $self->unpackRef($tree);
	}
}

sub unpack {
	my $self=shift;
	my $bom=shift;
	$self->{COMMENTS}={};
	$self->{References}=[];
	$self->{Ref}={};
	$self->bom($bom);
	my $encoding = $self->get(1);
	$self->die("No Encoding!") unless defined $encoding;
	$self->encoding(CORE::unpack("C",$encoding));
	my $tree="";
	my %result=();
	$self->getComment("=");
	while (defined (my $key = $self->getText())) {
		my $kkey = Data::Sofu::Sofukeyescape($key);
		my $type = $self->getType();
		$result{$key} = $self->unpackType($type,"$tree->$kkey");
		$self->{Ref}->{"$tree->$kkey"}=$result{$key};
		push @{$self->{References}},\$result{$key} if ($type == 4);
	}
	$self->{Ref}->{"="}=\%result;
	$self->postprocess(); #Setting References right.
	return (\%result,$self->{COMMENTS});
	
}

sub unpackUndefined {
	my $self=shift;
	my $tree=shift;
	my $und = Data::Sofu::Undefined->new();
	$self->getComment($und);
	return $und;

}

sub unpackValue {
	my $self=shift;
	my $tree=shift;
	my $value = Data::Sofu::Value->new("");
	$self->getComment($value);
	$value->set($self->getText());
	return $value;

}

sub unpackReference {
	my $self=shift;
	my $tree=shift;
	my $ref = Data::Sofu::Reference->new();
	$self->getComment($ref);
	$ref->dangle($self->getText());
	return $ref;

}

sub unpackMap {
	my $self=shift;
	my $tree=shift;
	my $map=Data::Sofu::Map->new();
	$self->getComment($map);
	my $len=$self->getLong($self->get(4));
	$self->die("Error while reading maplength, maybe EOF") unless defined $len;
	return $map if $len == 0;
	for (my $i = 0;$i < $len;$i++) {
		my $key = $self->getText();
		$self->die("Error while reading key, maybe EOF") unless defined $key;
		my $kkey = Data::Sofu::Sofukeyescape($key);
		my $type = $self->getType();
		my $res = $self->unpackObjectType($type,"$tree->$kkey");
		$self->{Ref}->{"$tree->$kkey"}=$res;
		push @{$self->{References}},$res if ($type == 4);
		$map->setAttribute($key,$res);
	}
	return $map;
	
}

sub unpackMap2 { #faster version, using the perlinterface
	my $self=shift;
	my $tree=shift;
	my %result=();
	my @order=();
	my $map=Data::Sofu::Map->new();
	$self->getComment($map);
	my $len=$self->getLong($self->get(4));
	$self->die("Error while reading maplength, maybe EOF") unless defined $len;
	return $map if $len == 0;
	keys(%result) = $len; #Presetting the Hashsize
	$#order=($len-1);
	for (my $i = 0;$i < $len;$i++) {
		my $key = $self->getText();
		$self->die("Error while reading key, maybe EOF") unless defined $key;
		my $kkey = Data::Sofu::Sofukeyescape($key);
		my $type = $self->getType();
		$result{$key} = $self->unpackObjectType($type,"$tree->$kkey");
		#push @order,$key;
		$order[$i] = $key;
		$self->{Ref}->{"$tree->$kkey"}=$result{$key};
		push @{$self->{References}},$result{$key} if ($type == 4);
	}
	$map->{Order}=\@order;
	$map->{Map}=\%result;
	return $map;
	
}

sub unpackList {
	my $self=shift;
	my $tree=shift;
	my $list=Data::Sofu::List->new();
	$self->getComment($list);
	my $len=$self->getLong($self->get(4));
	$self->die("Error while reading listlength, maybe EOF") unless defined $len;
	return $list if $len == 0;
	for (my $i = 0;$i < $len;$i++) {
		my $type = $self->getType();
		my $res = $self->unpackObjectType($type,"$tree->$i");
		$self->{Ref}->{"$tree->$i"}=$res;
		push @{$self->{References}},$res if ($type == 4);
		$list->appendElement($res);
	}
	return $list;
	
}

sub unpackList2 { #faster version, using the perlinterface
	my $self=shift;
	my $tree=shift;
	my $list=Data::Sofu::List->new();
	$self->getComment($list);
	my @result;
	my $len=$self->getLong($self->get(4));
	$self->die("Error while reading listlength, maybe EOF") unless defined $len;
	return $list if $len == 0;
	#die $len,"\n";
	$#result = $len-1; #Grow the Array :)
	for (my $i = 0;$i < $len;$i++) {
		my $type = $self->getType();
		$result[$i] = $self->unpackObjectType($type,"$tree->$i");
		$self->{Ref}->{"$tree->$i"}=$result[$i];
		push @{$self->{References}},$result[$i] if ($type == 4);
	}
	$list->{List}=\@result;
	return $list;
	
}

sub unpackObjectType {
	my $self=shift;
	my $type=shift;
	my $tree=shift;
	if ($type == 0) {
		return $self->unpackUndefined($tree);
	}
	elsif ($type == 1) {
		return $self->unpackValue($tree);
	}
	elsif ($type == 2) {
		return $self->unpackList2($tree);
	}
	elsif ($type == 3) {
		return $self->unpackMap2($tree);
	}
	elsif ($type == 4) {
		return $self->unpackReference($tree);
	}
}

sub unpackObject {
	my $self=shift;
	my $bom=shift;
	$self->{References}=[];
	$self->{Ref}={};
	$self->bom($bom);
	my $encoding = $self->get(1);
	$self->die("No Encoding!") unless defined $encoding;
	$self->encoding(CORE::unpack("C",$encoding));
	my $tree="";
	my $map = Data::Sofu::Map->new();
	$self->getComment($map);
	while (defined (my $key = $self->getText())) {
		my $kkey = Data::Sofu::Sofukeyescape($key);
		my $type = $self->getType();
		my $res = $self->unpackObjectType($type,"$tree->$kkey");
		$self->{Ref}->{"$tree->$kkey"}=$res;
		push @{$self->{References}},$res if ($type == 4);
		$map->setAttribute($key,$res);

	}
	$self->{Ref}->{"="}=$map;
	$self->objectprocess(); #Setting References right.
	return $map;
	
}

sub packType {
	my $self=shift;
	my $type=shift;
	my $str="";
	if ($self->{Mark}) {
		$str="Sofu" if rand() < $self->{Mark};
	}
	return $str.pack("C",$type);
}

sub packText {
	my $self=shift;
	my $text=shift;
	return $self->packLong(0) if not defined $text or $text eq "";
	$text = Encode::encode($self->{Encoding},$text,Encode::FB_CROAK);
	return $self->packLong(length($text)).$text;
}

sub packData {
	my $self=shift;
	my $data=shift;
	my $tree=shift;
	my $type=1;
	if (ref $data) {
		my $r=ref $data;
		if ($r eq "ARRAY") {
			$type=2;
		}
		elsif ($r eq "HASH") {
			$type=3;
		}
		else {
			$self->die("Unknown Datastructure, can only work with Arrays and Hashes but not $r");
		}
		if ($self->{SEEN}->{$data}) {
			return $self->packType(4).$self->packComment($tree).$self->packText("@".$self->{SEEN}->{$data});
		}
	}
	else {
		if (defined ($data)) {
			return $self->packType(1).$self->packComment($tree).$self->packText($data);
		}
		else {
			return $self->packType(0).$self->packComment($tree);
		}
	}
	$self->{SEEN}->{$data}=$tree;
	if ($type==3) {
		return $self->packType(3).$self->packComment($tree).$self->packHash($data,$tree);
	}
	return $self->packType(2).$self->packComment($tree).$self->packArray($data,$tree);
}

sub packArray {
	my $self=shift;
	my $data=shift;
	my $tree=shift;
	my $str=$self->packLong(scalar @{$data});
	my $i=0;
	foreach my $element (@{$data}) {
		$str.=$self->packData($element,"$tree->".$i++);
	}
	return $str;
}

sub packHash {
	my $self=shift;
	my $data=shift;
	my $tree=shift;
	my $str=$self->packLong(scalar keys %{$data});
	foreach my $key (keys %{$data}) {
		my $kkey = Data::Sofu::Sofukeyescape($key);
		$str.=$self->packText($key);
		$str.=$self->packData($data->{$key},"$tree->$kkey");
	}
	return $str;
}

sub pack { #Built tree into b-stream
	my $self=shift;
	$self->{OFFSET}="while packing";
	$self->{SEEN}={};
	my $data=shift;
	my $r = ref $data;
	return $self->packObject($data,@_) if $r and $r =~ m/Data::Sofu::/ and $data->isa("Data::Sofu::Object"); 
	$data = {Value=>$data} unless ref $data and ref $data eq "HASH";
	#$self->die("Data format wrong, must be hashref") unless (ref $data and ref $data eq "HASH");
	$self->{SEEN}->{$data}="->";
	my $comments=shift;
	$comments = {} unless defined $comments;
	$self->die("Comment format wrong, must be hashref") unless (ref $comments and ref $comments eq "HASH");
	$self->{Comments}=$comments;
	my $tree;
	#my $encoding=shift;
	#my $byteorder=shift;
	#$encoding=0 unless $encoding;
	#$byteorder=0 unless $byteorder;
	#$self->encoding($encoding) unless $self->byteorder($byteorder);
	#my $mark=shift;
	#$mark = undef unless $mark;
	#$self->{Mark} = $mark;
	#my $str = "";
	#$str.="Sofu" if $mark or not defined $mark;
	#$str.=$self->packendian();
	#$str.=$self->packversion()
	#$comments = {} unless defined $comments;;
	#$str.=$self->packencoding();
	my $str=$self->packHeader(@_);
	$str.=$self->packComment("=");
	foreach my $key (keys %{$data}) {
		$str.=$self->packText($key);
		$str.=$self->packData($data->{$key},"->".Data::Sofu::Sofukeyescape($key));
	}

	return $str;
}

sub packObject { # Use the Object implemented Packer for now.
	my $self=shift;
	my $data=shift;
	my $r = ref $data;
	$self->{OFFSET}="while packing";
	$self->{SEEN}={};
	$self->die("Need an Object") unless $r and $r =~ m/Data::Sofu::/ and $data->isa("Data::Sofu::Object"); 
	#return $data->binaryPack(@_);
	#die "Not implemented for now";
	unless ($data->isMap()) {
		require Data::Sofu::Map;
		my $x = Data::Sofu::Map->new();
		$x->setAttribute("Value",$data);
		$data=$x;
	}
	$self->{SEEN}->{$data}="->";
	my $comments=shift;
	$comments = {} unless defined $comments;
	$self->die("Comment format wrong, must be hashref") unless (ref $comments and ref $comments eq "HASH");
	$self->{Comments}=$comments;
	my $str=$self->packHeader(@_);
	$str.=$self->packComment("=",$data->getComment());
	foreach my $key ($data->orderedKeys()) {
		#print $key,"\n";
		my $kkey = Data::Sofu::Sofukeyescape($key);
		$str.=$self->packText($key);
		$str.=$self->packObjectData($data->object($key),"->$kkey");
	}
	#die $str;
	return $str;
}

sub packObjectData {
	my $self=shift;
	my $data=shift;
	my $tree=shift;
	my $type=1;
	my $r = ref $data;
	#Maybe call packData on unknown Datastructures..... :)
	die ("Unknown Datastructure, can only work with Arrays and Hashes but not $r") unless $r and $r =~ m/Data::Sofu/ and $r->isa("Data::Sofu::Object");
	my $odata=$data;
	if ($data->isReference() and $data->valid()) {
		$data=$data->follow();
	}
	if ($data->isReference()) { #Reference to a Reference not yet allowed!
		confess("No Reference to a Reference allowed for now!");
		return $self->packType(4).$self->packComment($tree,$odata->getComment()).$self->packText("@".$data->follow());
	}
	if ($self->{SEEN}->{$data}) {
		#Carp::cluck();
		#print "\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n";
		return $self->packType(4).$self->packComment($tree,$odata->getComment()).$self->packText("@".$self->{SEEN}->{$data});
	}
	$self->{SEEN}->{$data}=$tree;
	$self->{SEEN}->{$odata}=$tree;
	if ($data->isValue()) {
		return $self->packType(1).$self->packComment($tree,$odata->getComment()).$self->packText($data->toString());
	}
	if ($data->isMap()) {
		return $self->packType(3).$self->packComment($tree,$odata->getComment()).$self->packMap($data,$tree);
	}
	if ($data->isList()) {
		return $self->packType(2).$self->packComment($tree,$odata->getComment()).$self->packList($data,$tree);
	}
	return $self->packType(0).$self->packComment($tree,$odata->getComment());
}

sub packList {
	my $self=shift;
	my $data=shift;
	my $tree=shift;
	my $str=$self->packLong($data->length());
	my $i=0;
	while (my $element = $data->next()) {
		$str.=$self->packObjectData($element,"$tree->".$i++);
	}
	return $str;
}

sub packMap {
	my $self=shift;
	my $data=shift;
	my $tree=shift;
	my $str=$self->packLong($data->length());
	#foreach my $key (keys %{$data}) {
	#while (my ($key,$value) = $data->each()) {
	foreach my $key ($data->orderedKeys()) {
		#print $key,"\n";
		my $kkey = Data::Sofu::Sofukeyescape($key);
		$str.=$self->packText($key);
		$str.=$self->packObjectData($data->object($key),"$tree->$kkey");
	}
	return $str;
}

sub packComment {
	my $self=shift;
	my $tree=shift;
	local $_;
	my $add=shift;
	if ($self->{Comments}->{$tree} or $add) {
		#$self->die("Comment format wrong for $tree, must be Arrayref");
		my @comments = ();
		@comments = @{$self->{Comments}->{$tree}} if (ref $self->{Comments}->{$tree} and ref $self->{Comments}->{$tree} eq "ARRAY");
		push @comments,@{$add} if $add and ref $add and ref $add eq "ARRAY";
		return $self->packText(join("\n",@comments));
	}
	else {
		return $self->packLong(0);
	}
	
}

sub packHeader { 
	my $self=shift;
	$self->{OFFSET}="while object packing";
	my $encoding=shift;
	my $byteorder=shift;
	$encoding=0 unless $encoding;
	$byteorder=0 unless $byteorder;
	$self->encoding($encoding) unless $self->byteorder($byteorder);
	my $mark=shift;
	#$mark = undef unless defined $mark;
	$self->{Mark} = $mark;
	#die $mark;
	my $str = "";
	$str.="Sofu" if $mark or not defined $mark;
	$str.=$self->packendian();
	$str.=$self->packversion();
	$str.=$self->packencoding();
	return $str;
}

1;