1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/Emakefile	Fri Apr 25 02:54:05 2008 +0530
     1.3 @@ -0,0 +1,2 @@
     1.4 +['erlang/*'].
     1.5 +{'*',[debug_info]}.

     2.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     2.2 +++ b/README	Fri Apr 25 02:54:05 2008 +0530
     2.3 @@ -0,0 +1,1 @@
     2.4 +Slurp is an object serialization library, currently implemented for Common Lisp, Erlang and Javascript.

     3.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     3.2 +++ b/erlang/slurp.hrl	Fri Apr 25 02:54:05 2008 +0530
     3.3 @@ -0,0 +1,24 @@
     3.4 +-define(Byte, 1).
     3.5 +-define(Unsigned_integer, 2).
     3.6 +-define(Unicode_string, 4).
     3.7 +-define(Cons, 7).
     3.8 +-define(KeyValue, 8).
     3.9 +-define(Nil, 9).
    3.10 +-define(Object, 10).
    3.11 +-define(Array_Mask, 16).
    3.12 +
    3.13 +-define(Byte_array, ?Array_Mask bor ?Byte).
    3.14 +-define(Utf_8_array, ?Array_Mask bor ?Utf_8).
    3.15 +-define(KeyValue_array, ?Array_Mask bor ?KeyValue).
    3.16 +-define(Object_array, ?Array_Mask bor ?Object).
    3.17 +
    3.18 +
    3.19 +
    3.20 +-define(MarshalDirective, 0).
    3.21 +-define(MarshalDirective_LoadStateDescriptor, 2).
    3.22 +
    3.23 +-define(Has_Named_Slots, 1).
    3.24 +-define(StateDescriptorBase, 64).
    3.25 +
    3.26 +-record(state_descriptor, {code, shape, package_string, name, slots}).
    3.27 +

     4.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     4.2 +++ b/erlang/slurp_decode.erl	Fri Apr 25 02:54:05 2008 +0530
     4.3 @@ -0,0 +1,117 @@
     4.4 +-module(slurp_decode).
     4.5 +-include("slurp.hrl").
     4.6 +-export([ read_object/0 ]).
     4.7 +
     4.8 +read_object( ) -> ClassCode = read_unsigned_integer(),
     4.9 +		  %log:log("handling type ~p", [ClassCode]),
    4.10 +					 if (ClassCode == 0) ->
    4.11 +						 "load meta",
    4.12 +						 MarshalCode = read_unsigned_integer(),
    4.13 +						 case MarshalCode of
    4.14 +						     ?MarshalDirective_LoadStateDescriptor -> StateDescriptor = read_state_descriptor(),
    4.15 +									       put(state_descriptors, dict:store( StateDescriptor#state_descriptor.code,
    4.16 +														  StateDescriptor, get(state_descriptors))),
    4.17 +									       read_object()
    4.18 +						 end;
    4.19 +					    true -> read_datum(ClassCode)
    4.20 +					 end.
    4.21 +
    4.22 +read_state_descriptor() ->
    4.23 +    Code = read_unsigned_integer(),
    4.24 +    Shape = read_unsigned_integer(),
    4.25 +    PackageString = read_unicode_string(),
    4.26 +    Name = list_to_atom(read_unicode_string()),
    4.27 +    SlotCount = read_unsigned_integer(),
    4.28 +    Slots = case SlotCount of
    4.29 +		0 -> [];
    4.30 +		_Else -> lists:map( fun(Item) -> read_unicode_string() end, lists:seq(1, SlotCount))
    4.31 +	    end, 
    4.32 +    %log:log("read state descriptor ~p", [Name]),
    4.33 +    #state_descriptor { code = Code,
    4.34 +			shape = Shape,
    4.35 +			package_string = PackageString,
    4.36 +			name = Name,
    4.37 +			slots = Slots }.
    4.38 +
    4.39 +read_datum(Type) ->    
    4.40 +    case Type of 
    4.41 +	?Byte_array -> read_byte_array();
    4.42 +	?Unsigned_integer -> read_unsigned_integer();
    4.43 +	?Unicode_string -> read_unicode_string();
    4.44 +%	?Utf_8_array -> read_utf8_array();
    4.45 +%	?Utf_8 -> read_utf8();
    4.46 +	?Cons -> read_cons( );
    4.47 +	?KeyValue_array -> read_key_value_array( );
    4.48 +	?KeyValue -> read_key_value( );
    4.49 +	?Object -> read_object();
    4.50 +	?Object_array -> read_object_array();
    4.51 +	?Nil -> [];
    4.52 +	_Else -> if Type >= ?StateDescriptorBase -> read_object_state( dict:fetch(Type, get(state_descriptors)));
    4.53 +		    true -> throw("unknown type") %abort
    4.54 +		 end
    4.55 +    end.
    4.56 +
    4.57 +read_object_state( StateDescriptor ) -> 
    4.58 +    Tuple_items = [ StateDescriptor#state_descriptor.name | lists:map( fun(SlotName) ->
    4.59 +									      read_object( ) end, StateDescriptor#state_descriptor.slots)],
    4.60 +    Record = list_to_tuple(Tuple_items),
    4.61 +    Record.
    4.62 +    
    4.63 +read_datums(_, 0) -> [];
    4.64 +read_datums( Type, Count ) -> Obj = read_datum( Type),
    4.65 +				    [Obj] ++ read_datums( Type, Count - 1 ).
    4.66 +
    4.67 +
    4.68 +read_unicode_string() ->    
    4.69 +    Length = read_unsigned_integer(),
    4.70 +    read_datums(?Unsigned_integer, Length).
    4.71 +
    4.72 +read_byte_array() ->
    4.73 +    Length = read_unsigned_integer(),
    4.74 +    %log:log("read byte array ~p", [Length]),
    4.75 +    list_to_binary(read_bytes(Length)).
    4.76 +
    4.77 +read_bytes(0) -> [];
    4.78 +read_bytes(Count) -> [apply(get(reader_function), []) | read_bytes(Count - 1)].
    4.79 +		
    4.80 +     
    4.81 +read_object_array() ->
    4.82 +    Dimensions = read_cons(),
    4.83 +    if length(Dimensions) == 1 ->
    4.84 +	    list_to_tuple(read_datums(?Object, element(1, Dimensions)));
    4.85 +       true ->
    4.86 +	    throw("unhandled object array with dimension size != 1" ++ Dimensions)
    4.87 +    end.
    4.88 +
    4.89 +read_string() ->
    4.90 +    Length = read_unsigned_integer(),
    4.91 +    read_datums(?Unsigned_integer, Length).
    4.92 +
    4.93 +read_symbol_array() ->
    4.94 +    Length = read_unsigned_integer(),
    4.95 +    list_to_atom(read_datums(?Unsigned_integer, Length)).
    4.96 +
    4.97 +read_cons( ) ->
    4.98 +    A = read_object( ),
    4.99 +    B = read_object( ),
   4.100 +    [A | B].
   4.101 +
   4.102 +read_key_value( ) ->
   4.103 +    A = read_object( ),
   4.104 +    B = read_object( ),
   4.105 +    { A, B }.
   4.106 +
   4.107 +read_key_value_array( ) ->
   4.108 +    Length = read_unsigned_integer(),
   4.109 +    Datums = read_datums( ?KeyValue, Length),
   4.110 +    dict:from_list(Datums).
   4.111 +
   4.112 +read_unsigned_integer() ->
   4.113 +     read_unsigned_integer(1).
   4.114 +
   4.115 +read_unsigned_integer( Multiplier) -> Byte = apply(get(reader_function), []),
   4.116 +				      %io:format("byte is ~p~n", [Byte]),
   4.117 +				      <<HighBit:1, LowBits:7>> = Byte,
   4.118 +				      if HighBit == 1 -> (Multiplier * LowBits) + read_unsigned_integer( Multiplier * 128);
   4.119 +					 true-> (Multiplier * LowBits)
   4.120 +				      end.

     5.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     5.2 +++ b/erlang/slurp_encode.erl	Fri Apr 25 02:54:05 2008 +0530
     5.3 @@ -0,0 +1,126 @@
     5.4 +-module(slurp_encode).
     5.5 +-include("slurp.hrl").
     5.6 +-export([write_object/1]).
     5.7 +
     5.8 +
     5.9 +map_outbound_object(Object) ->
    5.10 +    RecordDescriptions = get(record_descriptions),
    5.11 +    case Object of 
    5.12 +	Object when (is_tuple(Object) and size(Object) >= 1) and (element(1, Object) == slurp_string) ->
    5.13 +	    write_integer(?Unicode_string),
    5.14 +	    write_unicode_string(element(2,Object)),
    5.15 +	    { mapped, Object };
    5.16 +	Object when (is_list(Object) and (length(Object) > 0)) ->
    5.17 +	    IsAString = lists:all( fun(X) -> is_integer(X) end, Object),
    5.18 +	    if IsAString ->
    5.19 +		    write_integer(?Unicode_string),
    5.20 +		    write_unicode_string(Object),
    5.21 +		    { mapped, Object };
    5.22 +	       true -> { unmapped, Object }
    5.23 +	    end;
    5.24 +	Object when (is_tuple(Object) and (size(Object) >= 1) and is_atom(element(1,Object))) ->
    5.25 +	    RecordName = list_to_atom(replaceDashWithUnderscore(atom_to_list(element(1, Object)))),
    5.26 +	    %log:log("finding ~p in ~p", [RecordName, RecordDescriptions]),
    5.27 +	    IsARecord = dict:find(RecordName, RecordDescriptions),
    5.28 +%	    io:format("isarecord ~p ~p~n", [RecordName, IsARecord]),
    5.29 +	    case IsARecord of
    5.30 +		{ ok, RecordFieldNames } -> { write_record, RecordName, RecordFieldNames, Object}; 
    5.31 +		error -> { unmapped, Object }
    5.32 +	    end;
    5.33 +	_Else -> %yio:format("else ~p ~p ~p ~p ~n",[is_tuple(Object), size(Object), element(1,Object), Object]),
    5.34 +		 { unmapped, Object }
    5.35 +    end.
    5.36 +
    5.37 +replaceDashWithUnderscore(String) ->
    5.38 +    lists:map( fun(Char) -> case Char of
    5.39 +				$- -> $_;
    5.40 +				_ -> Char
    5.41 +			    end
    5.42 +	       end,
    5.43 +	       String).
    5.44 +
    5.45 +replaceUnderscoreWithDash(String) ->
    5.46 +    lists:map( fun(Char) -> case Char of
    5.47 +				$_ -> $-;
    5.48 +				_ -> Char
    5.49 +			    end
    5.50 +	       end,
    5.51 +	       String).
    5.52 +
    5.53 +write_object(Object) ->
    5.54 +  %log:log("writing object ~p~n", [ Object ]),
    5.55 +    case map_outbound_object(Object) of
    5.56 +	{unmapped, MappedObject} ->
    5.57 +	    case MappedObject of
    5.58 +		[] -> write_integer( ?Nil);
    5.59 +		MappedObject when is_binary(MappedObject) -> write_integer( ?Byte_array),
    5.60 +							     write_byte_array( MappedObject);
    5.61 +		MappedObject when is_integer(MappedObject) -> write_integer( ?Unsigned_integer),
    5.62 +							      write_integer( MappedObject);
    5.63 +		MappedObject when is_list(MappedObject) -> write_integer( ?Cons),
    5.64 +							   write_cons( MappedObject);
    5.65 +		MappedObject when is_tuple(MappedObject) -> write_integer( ?Object_array),
    5.66 +							    write_object_array( MappedObject);
    5.67 +		MappedObject when is_atom(MappedObject) -> write_integer( ?Unicode_string),
    5.68 +							   write_unicode_string( atom_to_list(MappedObject));
    5.69 +		_Else  -> log:log("cannot encode ~p", [MappedObject]),
    5.70 +				  throw("unhandled " ++ MappedObject)
    5.71 +	    end;
    5.72 +	{mapped, _ } -> Object;
    5.73 +	{write_record, RecordName, RecordFieldNames, Record} -> %io:format("writing record~n",[]),
    5.74 +								write_record(RecordName, RecordFieldNames, Record)
    5.75 +    end.
    5.76 +
    5.77 +write_record(RecordName, RecordFieldNames, Record) ->
    5.78 +    write_integer(?MarshalDirective),
    5.79 +    write_integer(?MarshalDirective_LoadStateDescriptor),
    5.80 +    DescriptorCode = getNextStateDescriptorCode(),
    5.81 +    write_integer(DescriptorCode),
    5.82 +    write_integer(?Has_Named_Slots), 
    5.83 +    write_unicode_string("furax"),
    5.84 +    write_unicode_string(replaceUnderscoreWithDash(atom_to_list(RecordName))),
    5.85 +    write_integer( length(RecordFieldNames) ),
    5.86 +    lists:foreach( fun(F) ->
    5.87 +			   write_unicode_string(replaceUnderscoreWithDash(atom_to_list(F))) end, RecordFieldNames),
    5.88 +    write_integer(DescriptorCode),
    5.89 +    lists:foreach( fun write_object/1, tl(tuple_to_list(Record))).
    5.90 +    
    5.91 +
    5.92 +write_symbol( String_as_atom) ->
    5.93 +    CharList = atom_to_list(String_as_atom),
    5.94 +    write_integer( length(CharList)),
    5.95 +    lists:foreach( fun write_integer/1, CharList).
    5.96 +
    5.97 +write_unicode_string( String) ->
    5.98 +    %io:format("wus ~p~n", [String]),
    5.99 +    write_integer( length(String)),
   5.100 +    lists:foreach( fun write_integer/1, String).
   5.101 +
   5.102 +
   5.103 +write_byte_array( Binary) ->
   5.104 +    write_integer( size(Binary)),
   5.105 +    write_bytes( Binary).
   5.106 +		  
   5.107 +write_bytes( <<>>) -> ok;
   5.108 +write_bytes( <<Byte:8,Rest/binary>>) -> apply(get(writer_function), [<<Byte>>]),
   5.109 +						      write_bytes( Rest).
   5.110 +    
   5.111 +write_byte( Byte) ->
   5.112 +    apply(get(writer_function), [Byte]).
   5.113 +
   5.114 +write_object_array( Tuple) ->
   5.115 +    write_cons( [ size(Tuple) ] ),
   5.116 +    lists:foreach(fun write_object/1, tuple_to_list(Tuple)).
   5.117 +
   5.118 +write_integer( Integer) when Integer >= 128 -> apply(get(writer_function), [ <<((Integer rem 128) + 128):8>> ]),
   5.119 +					       write_integer( Integer div 128);
   5.120 +write_integer( Integer) -> apply(get(writer_function), [ <<Integer:8>> ]).
   5.121 +
   5.122 +write_cons( [A|B]) ->
   5.123 +    write_object( A),
   5.124 +    write_object( B).
   5.125 +	    
   5.126 +getNextStateDescriptorCode() ->	  
   5.127 +    Code = get(next_state_descriptor),
   5.128 +    put(next_state_descriptor, Code + 1),
   5.129 +    Code.

     6.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     6.2 +++ b/javascript/slurp.js	Fri Apr 25 02:54:05 2008 +0530
     6.3 @@ -0,0 +1,316 @@
     6.4 +var slurp_state_descriptor_map = new Object();
     6.5 +
     6.6 +function slurp_error(message) {
     6.7 +    this.message = message;
     6.8 +    console.warn("slurp error %s", message);
     6.9 +}
    6.10 +
    6.11 +function slurp_Nil() {}
    6.12 +function slurp_Cons(A, B) { this.A = A; this.B = B;}
    6.13 +
    6.14 +slurp_Cons.prototype['SLURP_TYPE'] = "SLURP_CONS";
    6.15 +
    6.16 +var reader_function = null;
    6.17 +
    6.18 +function string_to_array(str) {
    6.19 +    var array = new Array();
    6.20 +    var len = str.length;
    6.21 +    for(var c = 0; c < len; c++) {
    6.22 +	array[c] = str.charCodeAt(c);
    6.23 +    }
    6.24 +    return array;
    6.25 +}
    6.26 +
    6.27 +function slurp_decode(encoded_string) {
    6.28 +    if (encoded_string == "") {
    6.29 +	return null;
    6.30 +    }
    6.31 +    var array = string_to_array(encoded_string);
    6.32 +    return slurp_decode_array ( array );
    6.33 +}
    6.34 +
    6.35 +function slurp_decode_array(byteArray) {
    6.36 +    var read_index = -1;
    6.37 +    
    6.38 +    reader_function = function () {
    6.39 +	read_index++;
    6.40 +	var byte = byteArray[read_index];
    6.41 +//	console.log("b %s", byte);
    6.42 +	return byte;
    6.43 +    };
    6.44 +    var obj = slurp_read_object();
    6.45 +    return obj;
    6.46 +}
    6.47 +
    6.48 +function slurp_read_object() {
    6.49 +    var classCode = 0;
    6.50 +    while( (classCode = slurp_read_unsigned_int()) == 0) {
    6.51 +	var marshalDirective = slurp_read_unsigned_int();
    6.52 +	switch (marshalDirective) {
    6.53 +	    case slurp_marshal_directive_load_state_descriptor: slurp_read_state_descriptor(); break;
    6.54 +	   default: return new slurp_error("can't handle marshal dir");
    6.55 +	}
    6.56 +    }
    6.57 +//    console.log("reading datum class code %s" , classCode);
    6.58 +    return slurp_read_datum(classCode);
    6.59 +}
    6.60 +
    6.61 +var slurp_marshal_directive = 0;
    6.62 +var slurp_marshal_directive_load_state_descriptor = 2;
    6.63 +
    6.64 +var slurp_array_mask = 16;
    6.65 +
    6.66 +var slurp_byte = 1;
    6.67 +var slurp_unsigned_integer = 2;
    6.68 +var slurp_unicode_string = 4;
    6.69 +var slurp_cons = 7;
    6.70 +var slurp_nil = 9;
    6.71 +var slurp_object = 10;
    6.72 +
    6.73 +var slurp_byte_array = slurp_byte + slurp_array_mask;
    6.74 +var slurp_object_array = slurp_object + slurp_array_mask;
    6.75 +
    6.76 +function slurp_read_unsigned_int() {
    6.77 +    var readValue, answer = 0, shifter = 1;
    6.78 +    var finished = 0;
    6.79 +    //    var count = 5;
    6.80 +    while(finished != 1) {
    6.81 +	readValue = reader_function();
    6.82 +	//	writeError("read val is " + readValue, true);
    6.83 +	if (readValue < 128) {
    6.84 +	    finished = 1;
    6.85 +	}
    6.86 +	if(finished != 1) {
    6.87 +	    readValue = readValue - 128;
    6.88 +	}
    6.89 +	answer = answer + (readValue * shifter);
    6.90 +	shifter = shifter * 128;
    6.91 +	//	count--;
    6.92 +	//	if (count == 0) return "FAILED";
    6.93 +    }
    6.94 +    return answer;
    6.95 +}
    6.96 +
    6.97 +function slurp_read_datum(classCode) {
    6.98 +    switch(classCode) {
    6.99 +    case slurp_unsigned_integer:
   6.100 +	return slurp_read_unsigned_int();
   6.101 +    case slurp_unicode_string:
   6.102 +	return slurp_read_unicode_string();
   6.103 +    case slurp_cons:
   6.104 +	return slurp_read_cons();
   6.105 +    case slurp_nil:
   6.106 +	return null;
   6.107 +    case slurp_byte_array:
   6.108 +	return slurp_read_byte_array();
   6.109 +    case slurp_object_array:
   6.110 +	return slurp_read_object_array();
   6.111 +    default:
   6.112 +	if (classCode >= 64) {
   6.113 +	    return slurp_read_state_object(classCode);
   6.114 +	}
   6.115 +    }
   6.116 +    return new slurp_error("read invalid class code " + classCode);
   6.117 +}
   6.118 +
   6.119 +function slurp_read_byte_array() {
   6.120 +	var length = slurp_read_unsigned_int();
   6.121 +	var array = new Array();
   6.122 +	for(var i = 0; i < length; i++) {
   6.123 +	    array[i] = reader_function(); 
   6.124 +	}	
   6.125 +  return array;
   6.126 +}
   6.127 +
   6.128 +function slurp_read_object_array() {
   6.129 +	var dimensions = slurp_read_cons();
   6.130 +	dimensions = slurp_cons_to_list(dimensions);
   6.131 +	if (dimensions.length != 1) {
   6.132 +		var SlurpError = new Error("bad dimensions read in read_object_array");
   6.133 +		throw SlurpError;
   6.134 +	}
   6.135 +	var array = new Array();
   6.136 +//	console.log("reading array length %s", dimensions[0]);
   6.137 +	for(var i = 0; i < dimensions[0]; i++) {
   6.138 +	 array[i] = slurp_read_object();
   6.139 +//	console.log("at %s read %s", i, Dumper(array[i]));
   6.140 +	}	
   6.141 +  return array;
   6.142 +}
   6.143 +
   6.144 +function slurp_read_cons() {
   6.145 +    var A = slurp_read_object();
   6.146 +    var B = slurp_read_object();
   6.147 +//	Dumper.popup(B);
   6.148 +//	console.log("tail is null %s %s", B, B == null);
   6.149 +    return new slurp_Cons(A, B);
   6.150 +}
   6.151 +
   6.152 +function slurp_cons_to_list(cons) {
   6.153 +    var acc = new Array();
   6.154 +    walk_cons_helper(cons, acc);
   6.155 +    return acc.reverse();	
   6.156 +}
   6.157 +
   6.158 +function walk_cons_helper(cons, acc) {
   6.159 +    if( cons instanceof slurp_Cons ) {
   6.160 +	//	writeError("A is " + cons.A + "<br/>",true);
   6.161 +	acc.push(cons.A); 
   6.162 +	walk_cons_helper( cons.B, acc);
   6.163 +    }
   6.164 +}
   6.165 +
   6.166 +function slurp_read_unicode_string() {
   6.167 +    var length = slurp_read_unsigned_int();
   6.168 +    var result = "";
   6.169 +    for(var i = 0; i < length; i++) {
   6.170 +	result = result + String.fromCharCode( slurp_read_unsigned_int());
   6.171 +    }
   6.172 +//    console.log("read unicode %s", result);
   6.173 +    return result;
   6.174 +}
   6.175 +
   6.176 +
   6.177 +function slurp_read_state_descriptor() {
   6.178 +    var code = slurp_read_unsigned_int();
   6.179 +    var shape = slurp_read_unsigned_int();
   6.180 +    var package_string = slurp_read_unicode_string();
   6.181 +    var name = slurp_read_unicode_string();
   6.182 +    var slot_count = slurp_read_unsigned_int();
   6.183 +    var slots = new Array();
   6.184 +    for(var i = 0; i < slot_count; i++) {
   6.185 +	slots[i] = slurp_read_unicode_string();
   6.186 +    }
   6.187 +    var sd = new state_descriptor(code, shape, package_string, name, slot_count, slots);
   6.188 +    slurp_state_descriptor_map[ '' + code ] = sd;
   6.189 +//    console.log("read state desc %s", Dumper.popup(sd));
   6.190 +    return sd;
   6.191 +}
   6.192 +
   6.193 +function state_descriptor(code, shape, package_string, name, slot_count, slots) {
   6.194 +    this.code = code;
   6.195 +    this.shape = shape;
   6.196 +    this.package_string = package_string;
   6.197 +    this.name = name;
   6.198 +    this.slot_count = slot_count;
   6.199 +    this.slots = slots;
   6.200 +    return this;
   6.201 +}
   6.202 +
   6.203 +function slurp_read_state_object(classCode) {
   6.204 +    var sd = slurp_state_descriptor_map[ classCode ];
   6.205 +    if (sd == null)
   6.206 +	return new slurp_error("missing state descriptor for class " + classCode);
   6.207 +    var obj = new Object();
   6.208 +    for(var i = 0; i < sd.slot_count; i++)
   6.209 +	{
   6.210 +	    obj[ sd.slots['' + i ] ] = slurp_read_object();
   6.211 +	}
   6.212 +    obj["SLURP_TYPE"] = sd.name;	
   6.213 +	//   console.log("loaded %s object", sd.name);
   6.214 +    return obj;
   6.215 +}
   6.216 +
   6.217 +var last_class_code = 64;
   6.218 +
   6.219 +var writer_function = null;
   6.220 +
   6.221 +function slurp_encode(obj) {
   6.222 + var outputArray = new Array();
   6.223 + writer_function = function (newByte) {
   6.224 +     outputArray.push(newByte);
   6.225 + }
   6.226 + slurp_write_object(obj);
   6.227 +
   6.228 +return String.fromCharCode.apply( null, outputArray);
   6.229 +}
   6.230 +
   6.231 +function slurp_write_object(obj) {
   6.232 +  if (typeof(obj) == "number") {
   6.233 +	slurp_write_unsigned_int(slurp_unsigned_integer);
   6.234 +	slurp_write_unsigned_int(obj);
   6.235 +  }
   6.236 +  else if(typeof(obj) == "string") {
   6.237 +	slurp_write_unsigned_int(slurp_unicode_string);
   6.238 +	slurp_write_unicode_string(obj);
   6.239 +  }
   6.240 +  else if ((obj == null) || (obj == undefined)) { 
   6.241 +//		  console.log("writing %s", obj);
   6.242 +//		  debugger;	
   6.243 +		  slurp_write_unsigned_int(slurp_nil);
   6.244 +  }
   6.245 +  else {	
   6.246 +  var type = obj['SLURP_TYPE'];
   6.247 +  if (type == 'undefined') {
   6.248 +	console.log('type of ' + obj + ' is undefined');
   6.249 +	}
   6.250 +	else if (type == "SLURP_CONS") {
   6.251 +	  slurp_write_unsigned_int(slurp_cons);
   6.252 +	  slurp_write_object( obj.A );
   6.253 +	  slurp_write_object( obj.B );
   6.254 +	} else {
   6.255 +	  var slots = new Array();
   6.256 +	  for (var property in obj) {
   6.257 +	    if (!((property == 'SLURP_TYPE') || (property == 'SLURP_PACKAGE'))) {
   6.258 +	 	   slots.push(property);
   6.259 +		}
   6.260 +	  }
   6.261 +	  var sd = new state_descriptor(last_class_code++, 1, obj['SLURP_PACKAGE'], type, slots.length, slots);
   6.262 +
   6.263 +	  slurp_write_unsigned_int( slurp_marshal_directive );
   6.264 +	  slurp_write_unsigned_int( slurp_marshal_directive_load_state_descriptor );
   6.265 +
   6.266 +	  slurp_write_state_descriptor(sd);
   6.267 +	  slurp_write_state_object(sd, obj);
   6.268 +	}
   6.269 +   }
   6.270 +}
   6.271 +
   6.272 +function slurp_write_state_descriptor(sd) {
   6.273 +	with(sd) {
   6.274 +		slurp_write_unsigned_int(code);
   6.275 +		slurp_write_unsigned_int(shape);
   6.276 +	        slurp_write_unicode_string(package_string);
   6.277 +		slurp_write_unicode_string(name);
   6.278 +		slurp_write_unsigned_int(slot_count);
   6.279 +
   6.280 +		for (var idx = 0; idx < slot_count; idx++) {
   6.281 +		  slurp_write_unicode_string(slots[idx]);
   6.282 +		}	
   6.283 +	}	
   6.284 +}
   6.285 +
   6.286 +function slurp_write_state_object(sd, obj) {
   6.287 +//	 console.log("writing object %s", obj);
   6.288 +//	 Dumper.popup(obj);
   6.289 +	slurp_write_unsigned_int(sd.code);
   6.290 +	for (var idx = 0; idx < sd.slot_count; idx++) {
   6.291 +	 var slot = sd.slots[idx];
   6.292 +	// console.log("writing slot %s with %s", slot, obj[slot]);
   6.293 +	 slurp_write_object( obj[slot] );
   6.294 +	}
   6.295 +}
   6.296 +
   6.297 +//or use Math.floor instead of parseInt
   6.298 +
   6.299 +function slurp_write_unsigned_int(num) {
   6.300 +	var carry = parseInt(num / 128);
   6.301 +	var writeValue = (num % 128);
   6.302 +	while (carry != 0) {
   6.303 +	 writer_function (writeValue + 128);
   6.304 +	 writeValue = carry % 128;
   6.305 +	 carry = parseInt(carry / 128);
   6.306 +	}
   6.307 +	writer_function(writeValue);
   6.308 +}
   6.309 +
   6.310 +function slurp_write_unicode_string(str) {
   6.311 +//	console.log("writing %s", str);
   6.312 +	var len = str.length;
   6.313 +	slurp_write_unsigned_int(len);
   6.314 +	for (var c = 0; c < len; c++) {
   6.315 +	  slurp_write_unsigned_int( str.charCodeAt(c));
   6.316 +	}
   6.317 +}
   6.318 +
   6.319 +

     7.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     7.2 +++ b/lisp/slurp.asd	Fri Apr 25 02:54:05 2008 +0530
     7.3 @@ -0,0 +1,8 @@
     7.4 +(defsystem slurp
     7.5 +  :description "SLURP"
     7.6 +  :version "0.01"
     7.7 +  :author "John Leuner"
     7.8 +  :licence "MIT License"
     7.9 +  :components ((:file "slurp" ))
    7.10 +  :depends-on (flexi-streams))
    7.11 +

     8.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     8.2 +++ b/lisp/slurp.lisp	Fri Apr 25 02:54:05 2008 +0530
     8.3 @@ -0,0 +1,454 @@
     8.4 +(defpackage #:slurp
     8.5 +  (:use #:cl  :flexi-streams)
     8.6 +  (:export :writer :reader :decode :encode :make-slurp-writer :make-slurp-reader)
     8.7 +)
     8.8 +(defpackage #:test-slurp
     8.9 +  (:use #:cl :slurp))
    8.10 +
    8.11 +(in-package :slurp)
    8.12 +
    8.13 +(declaim (optimize (speed 0) (safety 3) (debug 3)))
    8.14 +
    8.15 +(defconstant +byte+ 1)
    8.16 +(defconstant +unsigned-integer+ 2)
    8.17 +(defconstant +signed-integer+ 3)
    8.18 +(defconstant +unicode-string+ 4)
    8.19 +(defconstant +cons+ 7)
    8.20 +(defconstant +key-value+ 8)
    8.21 +(defconstant +nil+ 9)
    8.22 +(defconstant +object+ 10) ; used for object array
    8.23 +
    8.24 +(defconstant +array-mask+ 16)
    8.25 +
    8.26 +(defconstant +byte-array+ (logior +byte+ +array-mask+))
    8.27 +(defconstant +key-value-array+ (logior +key-value+ +array-mask+))
    8.28 +(defconstant +object-array+ (logior +object+ +array-mask+)) 
    8.29 +
    8.30 +(defconstant +state-descriptor-base+ 64) ; all state descriptors have a code greater than or equal to this
    8.31 +
    8.32 +(defconstant +marshal-directive+ 0)
    8.33 +
    8.34 +(defconstant +marshal-directive-load-relative-offset+ 1) ; directive to load an object that has already been loaded previously
    8.35 +(defconstant +marshal-directive-load-metastate+ 2) ; directive to load a metastate description from the stream
    8.36 +(defconstant +marshal-directive-skip-bytes+ 3) ; directive to load an array of bytes and ignore them
    8.37 +(defconstant +marshal-directive-ignore-object+ 3) ; directive to load an object from the stream, but ignore it
    8.38 +
    8.39 +(defconstant HAS-NAMED-SLOTS 1)
    8.40 +(defconstant HAS-TYPED-NAMED-SLOTS 2)
    8.41 +(defconstant HAS-INDEXED-PART 4)
    8.42 +(defconstant HAS-VERSION-NUMBER-ARRAY 8)
    8.43 +(defconstant IS_STATELESS 16)
    8.44 +(defconstant IS_NAMED 32)
    8.45 +(defconstant IS_TYPED 64)
    8.46 +
    8.47 +(defclass state-descriptor () ((code :initarg :code :reader code)
    8.48 +			       (shape :initarg :shape :reader shape)
    8.49 +			       (package-string :initarg :package-string :reader package-string)
    8.50 +			       (name :initarg :name :reader name)
    8.51 +			       (named-slots :initarg :named-slots :reader named-slots)))
    8.52 +
    8.53 +(defgeneric has-named-slots (state-descriptor))
    8.54 +(defmethod has-named-slots ((state-descriptor state-descriptor))
    8.55 +  (not (null (named-slots state-descriptor))))
    8.56 +
    8.57 +(defclass placeholder () ((base-object :initarg :base-object :accessor base-object)))
    8.58 +
    8.59 +(defclass writer ()
    8.60 +  ((lisp-stream :initarg :stream :accessor lisp-stream)
    8.61 +   (save-stack :initform (make-array 10 :adjustable t :fill-pointer 0) :accessor save-stack)
    8.62 +   (state-descriptors :initform (make-hash-table) :accessor state-descriptors)))
    8.63 +
    8.64 +(defclass reader ()
    8.65 +  ((lisp-stream :initarg :stream :accessor lisp-stream)
    8.66 +   (load-stack :initform (make-array 10 :adjustable t :fill-pointer 0) :accessor load-stack)
    8.67 +   (state-descriptors :initform (make-hash-table) :accessor state-descriptors)))
    8.68 +
    8.69 +(defclass input-stream () ())
    8.70 +
    8.71 +(defgeneric slurp-type (object))
    8.72 +(defgeneric read-datum (stream type-indicator))
    8.73 +(defgeneric write-datum (stream type-indicator object))
    8.74 +
    8.75 +(defgeneric make-slurp-input-stream (underlying))
    8.76 +(defgeneric make-slurp-output-stream (underlying))
    8.77 +
    8.78 +(defun make-slurp-reader (stream)
    8.79 +  (make-instance 'reader :stream stream))
    8.80 +
    8.81 +(defun make-slurp-writer (stream)
    8.82 +  (make-instance 'writer :stream stream))
    8.83 +
    8.84 +(defun decode (buffer)
    8.85 +  (let* ((reader (make-slurp-reader (flexi-streams:make-in-memory-input-stream buffer))))
    8.86 +    (read-object reader)))
    8.87 +
    8.88 +(defun encode (object)
    8.89 +  (let* ((writer (make-slurp-writer (flexi-streams:make-in-memory-output-stream))))
    8.90 +    (write-object writer object)
    8.91 +    (flexi-streams:get-output-stream-sequence (lisp-stream writer))))
    8.92 +
    8.93 +(defvar *writer*)
    8.94 +(defvar *save-stack*)
    8.95 +
    8.96 +(defvar *reader*)
    8.97 +(defvar *load-stack*)
    8.98 +(defvar *state-descriptors*)
    8.99 +
   8.100 +(defgeneric discard-placeholders (placeholder-or-object recursion-set))
   8.101 +; reading and writing lisp objects from a slurp stream
   8.102 +(defgeneric read-object (reader))
   8.103 +(defgeneric write-object (writer object))
   8.104 +
   8.105 +(defmethod read-object ((reader reader))
   8.106 +  (let* ((stream (lisp-stream reader))
   8.107 +	 (*reader* reader)
   8.108 +	 (*load-stack* (load-stack reader))
   8.109 +	 (*state-descriptors* (state-descriptors reader))
   8.110 +	 (placeholder (do ((class-code (read-datum stream +unsigned-integer+)
   8.111 +				       (read-datum stream +unsigned-integer+)))
   8.112 +		     ((not (eq class-code 0)) (read-datum stream class-code))
   8.113 +		   (let ((marshal-directive (read-datum stream +unsigned-integer+)))
   8.114 +		     (cond ((eq marshal-directive +marshal-directive-load-metastate+) 
   8.115 +			    (let ((state-descriptor (read-state-descriptor stream)))
   8.116 +			      ;(break state-descriptor)
   8.117 +			      (setf (gethash (code state-descriptor) *state-descriptors*) state-descriptor)
   8.118 +			      ))
   8.119 +			   (t (error (format nil "unknown marshal directive ~A ~A" marshal-directive +marshal-directive-load-metastate+)))
   8.120 +			   )
   8.121 +		     ))))
   8.122 +    (discard-placeholders  placeholder (make-hash-table))))
   8.123 +
   8.124 +(defmethod read-object :around ((reader reader))
   8.125 +  (let ((foo (call-next-method reader)))
   8.126 +    ;    (format t "ro ~A~%" foo)
   8.127 +    foo))
   8.128 +
   8.129 + (defmethod write-object ((writer writer) object)
   8.130 +  (let ((stream (lisp-stream writer))
   8.131 +	(*writer* writer)
   8.132 +	(*state-descriptors* (state-descriptors writer)))
   8.133 +    (if (null object)
   8.134 +	  (write-datum stream +unsigned-integer+ +nil+)
   8.135 +	  (typecase object
   8.136 +	    (cons (progn (write-datum stream +unsigned-integer+ +cons+)
   8.137 +			 (write-datum stream +cons+ object)
   8.138 +			 ))
   8.139 +	    (integer (progn (write-datum stream +unsigned-integer+ +unsigned-integer+)
   8.140 +			    (write-datum stream +unsigned-integer+ object)))
   8.141 +	    (symbol (progn (write-datum stream +unsigned-integer+ +unicode-string+)
   8.142 +			   (write-datum stream +unicode-string+ (string object))))
   8.143 +	    (string (progn (write-datum stream +unsigned-integer+ +unicode-string+)
   8.144 +			   (write-datum stream +unicode-string+ object)))
   8.145 +	    (hash-table (progn (write-datum stream +unsigned-integer+ +key-value-array+)
   8.146 +			       (write-datum stream +unsigned-integer+ (hash-table-count object))
   8.147 +			       (loop for k being the hash-keys in object using (hash-value v) 
   8.148 +				     do (write-datum writer +key-value+ (cons k v)))))
   8.149 +	    ((vector (unsigned-byte 8)) (progn (write-datum stream +unsigned-integer+ +byte-array+)
   8.150 +					       (write-datum stream +unsigned-integer+ (length object))
   8.151 +					       (write-sequence object stream)))
   8.152 +	    ((vector t) 
   8.153 +	     (progn
   8.154 +	       (write-datum stream +unsigned-integer+ +object-array+)
   8.155 +	       (write-datum stream +object-array+ object)))
   8.156 +	     ((simple-array t) 
   8.157 +	      (progn
   8.158 +		(write-datum stream +unsigned-integer+ +object-array+)
   8.159 +		(write-datum stream +object-array+ object)))
   8.160 +	    (t (let ((state-descriptor (find-state-descriptor-by-class (class-of object))))
   8.161 +		 (when (null state-descriptor)
   8.162 +;		   (format t "could not find sd for obj ~A of class ~A~%" object (class-of object))
   8.163 +		   (setf state-descriptor (make-state-descriptor (class-of object)))
   8.164 +		   (write-state-descriptor stream state-descriptor))
   8.165 +		 (write-datum stream +unsigned-integer+ (code state-descriptor))
   8.166 +		 (write-datum stream state-descriptor object)
   8.167 +		 ))))))
   8.168 +
   8.169 +(defmethod discard-placeholders ((placeholder placeholder) recursion-set)
   8.170 +  (let ((lookup (gethash placeholder recursion-set)))
   8.171 +    (if lookup
   8.172 +	(base-object placeholder)
   8.173 +	(progn 
   8.174 +	  (setf (gethash placeholder recursion-set) placeholder)
   8.175 +	  (discard-placeholders (base-object placeholder) recursion-set)))))
   8.176 +
   8.177 +(defmethod discard-placeholders ((object t) recursion-set)
   8.178 +  (let ((lookup (gethash object recursion-set)))
   8.179 +    (if lookup
   8.180 +	object
   8.181 +	(let* ((class (class-of object))
   8.182 +	       (slots (sb-pcl:class-slots class)))
   8.183 +	  (setf (gethash object recursion-set) object)
   8.184 +	  (loop for s in slots do (let ((name (sb-pcl:slot-definition-name s)))
   8.185 +				    (setf (slot-value object name) 
   8.186 +					  (discard-placeholders (slot-value object name) recursion-set))))
   8.187 +	  object))))
   8.188 +
   8.189 +(defun make-state-descriptor (class)
   8.190 +  (let* ((code (+ 1 (hash-table-count *state-descriptors*) +state-descriptor-base+))
   8.191 +	 (slots (sb-pcl:class-slots class))
   8.192 +	 (state-descriptor (make-instance 'state-descriptor 
   8.193 +					  :code code
   8.194 +					  :shape (logior (if slots
   8.195 +							     HAS-NAMED-SLOTS
   8.196 +							     0))
   8.197 +					  :package-string (package-name (symbol-package (class-name class)))
   8.198 +					  :name (symbol-name (class-name class))
   8.199 +					  :named-slots (loop for slot in slots collect (string (sb-pcl:slot-definition-name slot))))))
   8.200 +    (setf (gethash class *state-descriptors*) state-descriptor)
   8.201 +;    (break "state descriptors ~A" *state-descriptors*)
   8.202 +    state-descriptor))
   8.203 +
   8.204 +(defun find-state-descriptor-by-code (code)
   8.205 +  (let ((lookup (gethash code *state-descriptors*)))
   8.206 +    (if (not lookup)
   8.207 +	(error (format nil "missing state-descriptor for code ~A" code) )
   8.208 +	lookup)))
   8.209 +
   8.210 +(defun find-state-descriptor-by-class (class)
   8.211 +  (let ((lookup (gethash class *state-descriptors*)))
   8.212 +    lookup))
   8.213 +
   8.214 +(defun write-state-descriptor (stream state-descriptor)
   8.215 +;  (format t "writing state descriptor ~A~%" state-descriptor)
   8.216 +  (write-datum stream +unsigned-integer+ +marshal-directive+)
   8.217 +  (write-datum stream +unsigned-integer+ +marshal-directive-load-metastate+)
   8.218 +  (write-datum stream +unsigned-integer+ (code state-descriptor))
   8.219 +  (write-datum stream +unsigned-integer+ (shape state-descriptor))
   8.220 +  (write-datum stream +unicode-string+ (package-string state-descriptor))
   8.221 +  (write-datum stream +unicode-string+ (name state-descriptor))
   8.222 +  (write-datum stream +unsigned-integer+ (list-length (named-slots state-descriptor)))
   8.223 +  (loop for slot in (named-slots state-descriptor) do (write-datum stream +unicode-string+ slot)))
   8.224 +
   8.225 +(defun read-state-descriptor (stream)
   8.226 +  (let* ((code (read-datum stream +unsigned-integer+))
   8.227 +	 (shape (read-datum stream +unsigned-integer+))
   8.228 +	 (package-string (read-datum stream +unicode-string+))
   8.229 +	 (name (read-datum stream +unicode-string+))
   8.230 +	 (slot-count (read-datum stream +unsigned-integer+))
   8.231 +	 (slots (loop for s from 1 to slot-count collect (read-datum stream +unicode-string+))))
   8.232 +    (make-instance 'state-descriptor :code code :shape shape :package-string package-string :name name :named-slots slots)))
   8.233 +
   8.234 +; mapping lisp objects to slurp types
   8.235 +
   8.236 +(defmethod slurp-type ((object integer))
   8.237 +  +unsigned-integer+)
   8.238 +
   8.239 +(defmethod slurp-type ((object cons))
   8.240 +  +cons+)
   8.241 +
   8.242 +(defmethod slurp-type ((object string))
   8.243 +  +unicode-string+)
   8.244 +
   8.245 +; reading and writing slurp data
   8.246 +(defgeneric modify-decoded-slot (object slot value))
   8.247 +(defmethod modify-decoded-slot  (object slot value)
   8.248 +  value)
   8.249 +  
   8.250 +
   8.251 +(defmethod read-datum (stream (state-descriptor-code integer))
   8.252 +  (assert (>= state-descriptor-code +state-descriptor-base+))
   8.253 +  (let* ((state-descriptor (find-state-descriptor-by-code state-descriptor-code))
   8.254 +	 (package (find-package (intern (string-upcase (package-string state-descriptor)) :keyword)))
   8.255 +	 (class-name (intern (name state-descriptor) package))
   8.256 +	 (newobject (make-instance class-name)) ; make an instance
   8.257 +	 (placeholder (make-instance 'placeholder :base-object newobject)))   ; make a placeholder 
   8.258 +;    (break placeholder newobject state-descriptor)
   8.259 +    (when (has-named-slots state-descriptor) 					; read the slots
   8.260 +      (loop for slot in (named-slots state-descriptor) do
   8.261 +	    (let ((slot-name (intern (string-upcase slot) package))
   8.262 +		  (value (read-object *reader*)))
   8.263 +	      (handler-case
   8.264 +		  (setf (slot-value newobject slot-name) (modify-decoded-slot newobject slot-name value))
   8.265 +		(simple-error (condition)
   8.266 +		   (format t "error ~A setting slot ~A in class ~A with value ~A~%" condition slot-name class-name value))))))
   8.267 +    placeholder))
   8.268 +
   8.269 +(defmethod write-datum (stream (state-descriptor state-descriptor) object)
   8.270 +;  (break state-descriptor)
   8.271 +  (when (has-named-slots state-descriptor)
   8.272 +    ;    (format t "writing state descriptor slots ~A ~%" (name state-descriptor))
   8.273 +    (loop for slot in (named-slots state-descriptor) do
   8.274 +	  (write-object *writer*
   8.275 +			(handler-case (slot-value object (intern slot (find-package (intern (package-string state-descriptor)))))
   8.276 +			  (unbound-slot () nil))))))
   8.277 +
   8.278 +(defmethod read-datum (stream (data-type (eql +nil+))) nil)
   8.279 +
   8.280 +(defmethod read-datum (stream (data-type (eql +byte+)))
   8.281 +  (read-byte stream))
   8.282 +
   8.283 +(defmethod write-datum (stream (data-type (eql +byte+)) obj)
   8.284 +  (write-byte obj stream))
   8.285 +
   8.286 +(defmethod write-datum (stream (data-type (eql +cons+)) obj)
   8.287 +  (write-object *writer* (first obj))
   8.288 +  (write-object *writer* (rest obj)))
   8.289 +
   8.290 +(defmethod write-datum (stream (data-type (eql +key-value+)) obj)
   8.291 +  (write-object *writer* (first obj))
   8.292 +  (write-object *writer* (rest obj)))
   8.293 +
   8.294 +(defmethod write-datum (stream (data-type (eql +object-array+)) (obj vector))
   8.295 +  (write-datum *writer* +cons+ (list (length obj)))
   8.296 +  (let ((length (length obj)))
   8.297 +    (loop for index from 0 below length 
   8.298 +	  do (write-object *writer* (elt obj index)))))
   8.299 +
   8.300 +(defmethod write-datum (stream (data-type (eql +object-array+)) obj)
   8.301 +  (write-datum *writer* +cons+ (array-dimensions obj))
   8.302 +  (let ((length (array-total-size obj)))
   8.303 +    (loop for index from 0 below length 
   8.304 +	  do (write-object *writer* (row-major-aref obj index)))))
   8.305 +
   8.306 +(defmethod read-datum (stream (data-type (eql +cons+)))
   8.307 +  (let ((A (read-object *reader*))
   8.308 +	(B (read-object *reader*)))
   8.309 +    (cons A B)))
   8.310 +
   8.311 +(defmethod read-datum (stream (data-type (eql +object-array+)))
   8.312 +  (let* ((dimensions (read-datum stream +cons+))
   8.313 +	 (buffer (make-array dimensions :element-type t))
   8.314 +	 (length (array-total-size buffer)))
   8.315 +    (loop for index from 0 below length do
   8.316 +	  (setf (row-major-aref buffer index) (read-object *reader*)))
   8.317 +    buffer))
   8.318 +
   8.319 +(defmethod read-datum (stream (data-type (eql +byte-array+)))
   8.320 +  (let* ((length (read-datum stream +unsigned-integer+))
   8.321 +	 (buffer (make-array length :element-type '(unsigned-byte 8))))
   8.322 +    (loop for index from 0 to (- length 1) do
   8.323 +	  (setf (aref buffer index) (read-byte stream)))
   8.324 +    buffer))
   8.325 +
   8.326 +(defmethod read-datum (stream (data-type (eql +unicode-string+)))
   8.327 +  (let* ((length (read-datum stream +unsigned-integer+))
   8.328 +	 (str (make-array length :element-type 'character)))
   8.329 +    (loop for index from 0 to (- (length str) 1) do 
   8.330 +	  (setf (char str index)
   8.331 +		(code-char (read-datum stream +unsigned-integer+))
   8.332 +		))
   8.333 +    (string str)))
   8.334 +
   8.335 +(defmethod read-datum (stream (data-type (eql +key-value-array+)))
   8.336 +  (let* ((count (read-datum stream +unsigned-integer+))
   8.337 +	 (ht (make-hash-table :size count)))
   8.338 +    (dotimes (counter count)
   8.339 +      (let ((key (read-object *reader*))
   8.340 +	    (value (read-object *reader*)))
   8.341 +	(setf (gethash (if (stringp key)
   8.342 +			   (intern key)
   8.343 +			   key)
   8.344 +		       ht) value))) ; hack, we turn string keys into symbols
   8.345 +    ht))
   8.346 +
   8.347 +(defmethod write-datum (stream (data-type (eql +unicode-string+)) (str string))
   8.348 +  (write-datum stream +unsigned-integer+ (length str))
   8.349 +  (loop for char across str do (write-datum stream +unsigned-integer+ (char-code char))))
   8.350 +
   8.351 +(defmethod write-datum (stream (data-type (eql +unsigned-integer+)) (num integer))
   8.352 +  (assert (>= num 0))
   8.353 +  (do ((carry (truncate num 128)) 
   8.354 +       (writeValue (rem num 128))) 
   8.355 +      ((equal carry 0) (write-byte writeValue stream))
   8.356 +    (write-byte (+ writeValue 128) stream)
   8.357 +;    (format t "write ~A carry ~A writing ~A~%" writeValue carry (+ writeValue 128))
   8.358 +    (setf writeValue (rem carry 128))
   8.359 +    (setf carry (truncate carry 128))))
   8.360 +
   8.361 +(defmethod read-datum (stream (data-type (eql +unsigned-integer+)))
   8.362 +  (do ((answer 0)
   8.363 +       (shifter 1)
   8.364 +       (atLast nil)
   8.365 +       (readValue))
   8.366 +      (atLast (progn
   8.367 +;		(format t "done ~A~%" answer)
   8.368 +		answer))
   8.369 +    (setf readValue (let ((val (read-byte stream)))
   8.370 +		      (if (typep val 'character)
   8.371 +			  (char-code val)
   8.372 +			  val)))
   8.373 +    (setf atLast (< readValue 128)) ; (equal (rem readValue 128) 0))
   8.374 +    (if (not atLast)
   8.375 +	(setf readValue (- readValue 128)))
   8.376 +    (setf answer (+ answer (* readValue shifter)))
   8.377 +    (setf shifter (* shifter 128))))
   8.378 +
   8.379 +; tests
   8.380 +
   8.381 +(defclass testA ()
   8.382 +  ((a)
   8.383 +   (b)
   8.384 +   (c)
   8.385 +   (d)))
   8.386 +
   8.387 +(defclass testB ()
   8.388 +  ((|apple|)
   8.389 +   (|bean|)
   8.390 +   (|cattle|)
   8.391 +   (|dog|)))
   8.392 +
   8.393 +(defun check-equal (A B)
   8.394 +  (if (not (equal A B))
   8.395 +      (break "~A is does not equal ~A" A B)))
   8.396 +
   8.397 +(defun testArray ()
   8.398 +  (let* ((array (make-array '(19 19) :initial-element nil))
   8.399 +	 (bytes (slurp::encode array)))
   8.400 +    bytes
   8.401 +    ;
   8.402 +  ;
   8.403 +   ;    (check-equal (decode bytes) array))
   8.404 +  ))
   8.405 +
   8.406 +
   8.407 +(defun test ()
   8.408 +  (simple-test)
   8.409 +  (with-open-file (stream "slurp-test.slurp" :direction :output :if-exists :overwrite :if-does-not-exist :create)
   8.410 +    (let ((objA (make-instance 'testA)))
   8.411 +      (setf (slot-value objA 'a) 22)
   8.412 +      (setf (slot-value objA 'b) "mohab")
   8.413 +      (setf (slot-value objA 'c) '(1 2 3))
   8.414 +      (setf (slot-value objA 'd) (make-array 3 :element-type '(unsigned-byte 8)
   8.415 +					     :initial-contents '(1 99 254)))
   8.416 +      (write-sequence (encode objA) stream) 
   8.417 +      )
   8.418 +    (with-open-file (file "/home/jewel/dev/furax/test-packet.slurp" :direction :input)
   8.419 +      (let ((s (make-string (file-length file))))
   8.420 +	(read-sequence s file)
   8.421 +	(let ((objB (decode s)))
   8.422 +	  (check-equal (first objB) 22))))))
   8.423 +
   8.424 +(defun simple-test ()
   8.425 +  (let ((objA (make-instance 'testA))
   8.426 +	(objB (make-instance 'testB)))
   8.427 +
   8.428 +    (setf (slot-value objA 'a) 22)
   8.429 +    (setf (slot-value objA 'b) "mohab")
   8.430 +    (setf (slot-value objA 'c) '(1 2 3))
   8.431 +    (setf (slot-value objA 'd) (make-array 3 :initial-contents '("a" "b" "c")))
   8.432 +    
   8.433 +    (setf (slot-value objB '|apple|) objA)
   8.434 +    (setf (slot-value objB '|bean|) 2)
   8.435 +    (setf (slot-value objB '|cattle|) 'grimace)
   8.436 +    (setf (slot-value objB '|dog|) :bumper)
   8.437 +
   8.438 +    (let* ((encA (encode objA))
   8.439 +	   (encB (encode objB))
   8.440 +	   (decA (decode encA))
   8.441 +	   (decB (decode encB)))
   8.442 +      (check-equal (slot-value objA 'a) (slot-value decA 'a))
   8.443 +      (check-equal (slot-value objA 'b) (slot-value decA 'b))
   8.444 +      (check-equal (slot-value objA 'c) (slot-value decA 'c))
   8.445 +      (check-equal (length (slot-value objA 'd))
   8.446 +		   (length (slot-value decA 'd)))
   8.447 +      (check-equal (class-of (slot-value decB '|apple|)) (class-of objA))
   8.448 +      (check-equal (slot-value objB '|bean|) (slot-value decB '|bean|))
   8.449 +      (check-equal (string (slot-value objB '|cattle|)) (slot-value decB '|cattle|))
   8.450 +      (check-equal (string (slot-value objB '|dog|)) (slot-value decB '|dog|)))))
   8.451 +
   8.452 +
   8.453 +
   8.454 +
   8.455 +    
   8.456 +
   8.457 +