balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Michelson: fix PACK/UNPACK

Browse Source
This commit is contained in:
Benjamin Canou 2018-06-30 12:26:06 +02:00
parent f59b0aa44f
commit ee7a67b915
3 changed files with 23 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
src/bin_client/test/contracts/packunpack.tz Normal file
View File

@ -0,0 +1,6 @@
parameter (pair (pair (pair string (list int)) (set nat)) bytes) ;
storage unit ;
code { CAR ; UNPAIR ; DIP { DUP } ;
PACK ; ASSERT_CMPEQ ;
UNPACK (pair (pair string (list int)) (set nat)) ; ASSERT_SOME ; DROP ;
UNIT ; NIL operation ; PAIR }

7
src/bin_client/test/test_contracts.sh
View File

@ -209,6 +209,13 @@ assert_storage $contract_dir/loop_left.tz '{""}' '{ "c" ; "b" ; "a" }' '{ "a" ;
assert_storage $contract_dir/exec_concat.tz '"?"' '""' '"_abc"' assert_storage $contract_dir/exec_concat.tz '"?"' '""' '"_abc"'
assert_storage $contract_dir/exec_concat.tz '"?"' '"test"' '"test_abc"' assert_storage $contract_dir/exec_concat.tz '"?"' '"test"' '"test_abc"'
# Test PACK/UNPACK and binary format
assert_success $client run script $contract_dir/packunpack.tz on storage Unit and input \
'(Pair (Pair (Pair "toto" {3;7;9;1}) {1;2;3}) 0x05070707070100000004746f746f020000000800030007000900010200000006000100020003)'
assert_fails $client run script $contract_dir/packunpack.tz on storage Unit and input \
'(Pair (Pair (Pair "toto" {3;7;9;1}) {1;2;3}) 0x05070707070100000004746f746f0200000008000300070009000102000000060001000200030004)'
# Get current steps to quota # Get current steps to quota
assert_storage $contract_dir/steps_to_quota.tz 111 Unit 399813 assert_storage $contract_dir/steps_to_quota.tz 111 Unit 399813

15
src/proto_alpha/lib_protocol/src/script_interpreter.ml
View File

@ -641,19 +641,24 @@ let rec interp
Script_ir_translator.pack_data ctxt t value >>=? fun (bytes, ctxt) -> Script_ir_translator.pack_data ctxt t value >>=? fun (bytes, ctxt) ->
logged_return (Item (bytes, rest), ctxt) logged_return (Item (bytes, rest), ctxt)
| Unpack t, Item (bytes, rest) -> | Unpack t, Item (bytes, rest) ->
begin match Data_encoding.Binary.of_bytes Script.lazy_expr_encoding bytes with Lwt.return (Gas.check_enough ctxt (Script.serialized_cost bytes)) >>=? fun () ->
if Compare.Int.(MBytes.length bytes >= 1) &&
Compare.Int.(MBytes.get_uint8 bytes 0 = 0x05) then
let bytes = MBytes.sub bytes 1 (MBytes.length bytes - 1) in
match Data_encoding.Binary.of_bytes Script.expr_encoding bytes with
| None -> | None ->
Lwt.return (Gas.consume ctxt (Interp_costs.unpack_failed bytes)) >>=? fun ctxt -> Lwt.return (Gas.consume ctxt (Interp_costs.unpack_failed bytes)) >>=? fun ctxt ->
logged_return (Item (None, rest), ctxt) logged_return (Item (None, rest), ctxt)
| Some lexpr -> | Some expr ->
(Script.force_decode ctxt lexpr >>=? fun (expr, ctxt) -> Lwt.return (Gas.consume ctxt (Script.deserialized_cost expr)) >>=? fun ctxt ->
parse_data ctxt t (Micheline.root expr)) >>= function parse_data ctxt t (Micheline.root expr) >>= function
| Ok (value, ctxt) -> | Ok (value, ctxt) ->
logged_return (Item (Some value, rest), ctxt) logged_return (Item (Some value, rest), ctxt)
| Error _ignored -> | Error _ignored ->
Lwt.return (Gas.consume ctxt (Interp_costs.unpack_failed bytes)) >>=? fun ctxt -> Lwt.return (Gas.consume ctxt (Interp_costs.unpack_failed bytes)) >>=? fun ctxt ->
logged_return (Item (None, rest), ctxt) logged_return (Item (None, rest), ctxt)
end else
logged_return (Item (None, rest), ctxt)
(* protocol *) (* protocol *)
| Address, Item ((_, contract), rest) -> | Address, Item ((_, contract), rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.address) >>=? fun ctxt -> Lwt.return (Gas.consume ctxt Interp_costs.address) >>=? fun ctxt ->