FEAT: implemented put action on object! (extending)

Author: Oldes

src/boot/actions.reb

@@ -284,7 +284,7 @@ take: action [
 
 put: action [
 	{Replaces the value following a key, and returns the new value.}
-	series [any-block! map! port!] {(modified)}
+	series [any-block! map! port! object!] {(modified)}
 	key    [scalar! any-string! any-word! binary!] 
 	value  [any-type!] {The new value (returned)}
 	/case  {Perform a case-sensitive search}

src/core/t-object.c

@@ -70,6 +70,35 @@ static REBOOL Equal_Object(REBVAL *val, REBVAL *arg)
 	return TRUE;
 }
 
+static void Extend_Obj(REBSER *obj, REBVAL *key, REBVAL *value)
+{
+	REBCNT index;
+	REBVAL *val;
+
+	// Key must be a word only!
+	if (ANY_WORD(key)) {
+		// bug fix, 'self is protected only in selfish frames
+		if ((VAL_WORD_CANON(key) == SYM_SELF) && !IS_SELFLESS(obj))
+			Trap0(RE_SELF_PROTECTED);
+		index = Find_Word_Index(obj, VAL_WORD_SYM(key), TRUE);
+		if (index) {
+			if (!value) return;
+			val = FRM_VALUE(obj, index);
+			if (VAL_PROTECTED(val)) Trap1(RE_LOCKED_WORD, val);
+		} else {
+			Expand_Frame(obj, 1, 1); // copy word table also
+			val = Append_Frame(obj, 0, VAL_WORD_SYM(key));
+		}
+		if (value)
+			*val = *value;
+		else
+			SET_UNSET(val);
+		return;
+	}
+	else {
+		Trap_Arg(key);
+	}
+}
 static void Append_Obj(REBSER *obj, REBVAL *arg, REBCNT part)
 {
 	REBCNT i, n, len;
@@ -78,14 +107,7 @@ static void Append_Obj(REBSER *obj, REBVAL *arg, REBCNT part)
 
 	// Can be a word:
 	if (ANY_WORD(arg)) {
-		if (!Find_Word_Index(obj, VAL_WORD_SYM(arg), TRUE)) {
-			// bug fix, 'self is protected only in selfish frames
-			if ((VAL_WORD_CANON(arg) == SYM_SELF) && !IS_SELFLESS(obj))
-				Trap0(RE_SELF_PROTECTED);
-			Expand_Frame(obj, 1, 1); // copy word table also
-			val = Append_Frame(obj, 0, VAL_WORD_SYM(arg));
-			SET_UNSET(val);
-		}
+		Extend_Obj(obj, arg, NULL);
 		return;
 	}
 
@@ -452,6 +474,15 @@ static REBSER *Trim_Object(REBSER *obj)
 		else
 			Trap_Action(VAL_TYPE(value), action); // !!! needs better error
 
+	case A_PUT:
+		TRAP_PROTECT(VAL_SERIES(value));
+		if (IS_OBJECT(value)) {
+			Extend_Obj(VAL_OBJ_FRAME(value), arg, D_ARG(3));
+			return R_ARG3;
+		}
+		else
+			Trap_Action(VAL_TYPE(value), action); // !!! needs better error
+
 	case A_LENGTHQ:
 		if (IS_OBJECT(value)) {
 			DS_RET_INT(SERIES_TAIL(VAL_OBJ_FRAME(value))-1);

src/mezz/codec-image-ext.reb

@@ -12,7 +12,7 @@ REBOL [
 ]
 
 if find codecs 'png [
-	extend codecs/png 'size? func ["Return PNG image size or none" bin [binary!]][
+	put codecs/png 'size? func ["Return PNG image size or none" bin [binary!]][
 		if all [
 			parse bin [
 				#{89504E470D0A1A0A} ;- PNG magic number
@@ -25,7 +25,7 @@ if find codecs 'png [
 		]
 	]
 
-	extend codecs/png 'chunks function [
+	put codecs/png 'chunks function [
 		"Decode PNG into block of chunks (or encode back to binary from a block)"
 		data [binary! file! url! block!] "Input data"
 		/only tags [block!]
@@ -116,7 +116,7 @@ if find codecs 'png [
 ]
 
 if find codecs 'jpeg [
-	extend codecs/jpeg 'size? function ["Return JPEG image size or none" img [file! url! binary!]][
+	put codecs/jpeg 'size? function ["Return JPEG image size or none" img [file! url! binary!]][
 		unless binary? img [img: read/binary img]
 		unless img: find/tail img #{FFD8} [return none]
 		while [2 <= length? img][
@@ -149,7 +149,7 @@ if find codecs 'jpeg [
 
 
 if find codecs 'gif [
-	extend codecs/gif 'size? function ["Return GIF image size or none" img [file! url! binary!]][
+	put codecs/gif 'size? function ["Return GIF image size or none" img [file! url! binary!]][
 		unless binary? img [img: read/binary/part img 16]
 		parse img [
 			["GIF87a" | "GIF89a"] img: (
@@ -161,7 +161,7 @@ if find codecs 'gif [
 ]
 
 if find codecs 'bmp [
-	extend codecs/bmp 'size? function ["Return BMP image size or none" img [file! url! binary!]][
+	put codecs/bmp 'size? function ["Return BMP image size or none" img [file! url! binary!]][
 		unless binary? img [img: read/binary/part img 32]
 		unless find/match img #{424D} [return none]
 		try [return to pair! binary/read img [SKIP 18 UI32LE UI32LE]]
@@ -170,7 +170,7 @@ if find codecs 'bmp [
 ]
 
 if find codecs 'dds [
-	extend codecs/dds 'size? function ["Return DDS image size or none" img [file! url! binary!]][
+	put codecs/dds 'size? function ["Return DDS image size or none" img [file! url! binary!]][
 		unless binary? img [img: read/binary/part img 32]
 		unless find/match img #{444453207C000000} [return none]
 		try [return to pair! reverse binary/read img [SKIP 12 UI32LE UI32LE]]
@@ -179,7 +179,7 @@ if find codecs 'dds [
 ]
 
 if find codecs 'qoi [
-	extend codecs/qoi 'size? function ["Return QOI image size or none" img [file! url! binary!]][
+	put codecs/qoi 'size? function ["Return QOI image size or none" img [file! url! binary!]][
 		unless binary? img [img: read/binary/part img 32]
 		unless find/match img #{716F6966} [return none]
 		try [return to pair! binary/read img [SKIP 4 UI32BE UI32BE]]

src/mezz/codec-pdf.reb

@@ -425,7 +425,7 @@ get-xref-count: function[xrefs n][
 
 emit-stream: func[obj [object!] /local data][
 	unless find obj 'spec [
-		extend obj 'spec #(Length: 0)
+		put obj 'spec #(Length: 0)
 	]
 	data: any [obj/data #{}]
 	unless any [           ; don't use compression 
@@ -643,7 +643,7 @@ register-codec [
 		]
 		trailer: select pdf 'trailer
 		unless trailer [
-			extend pdf 'trailer trailer: #(Info: #[none] Root: #[none])
+			put pdf 'trailer trailer: #(Info: #[none] Root: #[none])
 		]
 		unless root: trailer/Root [
 			sys/log/debug 'PDF "Trying to locate `Catalog` in PDF objects."

src/mezz/prot-mysql.reb

@@ -1474,7 +1474,7 @@ mysql-driver: make object! [
 	]
 
 
-	extend system/catalog/errors 'MySQL make object! [
+	put system/catalog/errors 'MySQL make object! [
 		code: 1000
 		type: "MySQL-errors"
 		message: ["[" :arg1 "]" :arg2] ;arg1: [error code] ;arg2: error message

src/mezz/sys-ports.reb

@@ -254,7 +254,7 @@ make-scheme: func [
 				|
 				'function set args block! set body block! (func*: function args body)
 			] (
-				forall name [append actor reduce [name/1 :func*]]
+				forall name [put actor name/1 :func*]
 			)
 			| end
 			| pos: (

src/tests/units/object-test.r3

@@ -39,6 +39,21 @@ Rebol [
 
 ===end-group===
 
+
+===start-group=== "PUT object"
+	--test-- "put object"
+		obj: object []
+		--assert 1 = put obj 'a 1 ; extends with a new key/value
+		--assert 1 = obj/a
+		--assert 2 = put obj 'a 2 ; overwrites existing
+		--assert 2 = obj/a
+		--assert 3 = put obj 'b 3
+		--assert 3 = obj/b
+		--assert unset? put obj 'b #[unset!]
+		--assert unset? obj/b
+===end-group===
+
+
 ===start-group=== "EXTEND object"
 	--test-- "extend object"
 		obj: object []

src/tests/units/protect-test.r3

@@ -130,6 +130,17 @@ Rebol [
 		--assert all [error? e: try [set in obj 'a 99] e/id = 'locked-word]
 		--assert all [error? e: try [set obj [99]] e/id = 'locked-word]
 
+	--test-- "EXTEND object!"
+		obj: object [a: 1] protect/deep 'obj
+		--assert all [error? e: try [obj/a: 2]  e/id = 'locked-word] 
+		--assert all [error? e: try [put obj 'a 2]  e/id = 'protected] ; cannot modify the value
+		--assert all [error? e: try [append obj [b: 2]]  e/id = 'protected]
+		--assert all [error? e: try [put obj 'b 2]  e/id = 'protected]
+		unprotect obj
+		--assert object? append obj [b: 2]
+		--assert all [22 = put obj 'a 22  22 == obj/a]
+		unprotect 'obj
+
 
 ===end-group===