restrict @:allow(some.pack) to types located in that package only (#8306)

src/context/typecore.ml

@@ -337,13 +337,22 @@ let rec can_access ctx ?(in_overload=false) c cf stat =
 		| EConst (Ident n) -> n :: acc
 		| _ -> []
 	in
-	let rec chk_path psub pfull =
+	let rec chk_path psub pfull is_current_path =
 		match psub, pfull with
 		| [], _ -> true
-		| a :: l1, b :: l2 when a = b -> chk_path l1 l2
+		| a :: l1, b :: l2 when a = b ->
+			if
+				(* means it's a path of a superclass or implemented interface *)
+				not is_current_path &&
+				(* it's the last part of path in a meta && it denotes a package *)
+				l1 = [] && not (StringHelper.starts_uppercase a)
+			then
+				false
+			else
+				chk_path l1 l2 is_current_path
 		| _ -> false
 	in
-	let has m c f path =
+	let has m c f (path,is_current_path) =
 		let rec loop = function
 			| (m2,el,_) :: l when m = m2 ->
 				List.exists (fun e ->
@@ -354,7 +363,7 @@ let rec can_access ctx ?(in_overload=false) c cf stat =
 						(match path with [_;_] -> true | _ -> false)
 					| _ ->
 						let p = expr_path [] e in
-						(p <> [] && chk_path p path)
+						(p <> [] && chk_path p path is_current_path)
 				) el
 				|| loop l
 			| _ :: l -> loop l
@@ -363,19 +372,19 @@ let rec can_access ctx ?(in_overload=false) c cf stat =
 		loop c.cl_meta || loop f.cf_meta
 	in
 	let cur_paths = ref [] in
-	let rec loop c =
-		cur_paths := make_path c ctx.curfield :: !cur_paths;
+	let rec loop c is_current_path =
+		cur_paths := (make_path c ctx.curfield, is_current_path) :: !cur_paths;
 		begin match c.cl_super with
-			| Some (csup,_) -> loop csup
+			| Some (csup,_) -> loop csup false
 			| None -> ()
 		end;
-		List.iter (fun (c,_) -> loop c) c.cl_implements;
+		List.iter (fun (c,_) -> loop c false) c.cl_implements;
 	in
-	loop ctx.curclass;
+	loop ctx.curclass true;
 	let is_constr = cf.cf_name = "new" in
 	let rec loop c =
 		try
-			has Meta.Access ctx.curclass ctx.curfield (make_path c cf)
+			has Meta.Access ctx.curclass ctx.curfield ((make_path c cf), true)
 			|| (
 				(* if our common ancestor declare/override the field, then we can access it *)
 				let allowed f = is_parent c ctx.curclass || (List.exists (has Meta.Allow c f) !cur_paths) in

tests/misc/projects/Issue6525/Main.hx

@@ -0,0 +1,21 @@
+import pack.BasePack;
+import pack.IPack;
+import pack.Pvt;
+
+class Main {
+	static function main() {
+
+	}
+}
+
+class Sub extends BasePack implements IPack {
+	override public function test() {
+		// should fail, because it allows access to specific package - pack
+		Pvt1.testPack();
+		Pvt2.testPack();
+		// should pass, because it allows access to all instances of pack.BasePack (including descendant classes)
+		Pvt2.testClass();
+		// should pass, because it allows access to all implementers of pack.IPack
+		Pvt2.testInterface();
+	}
+}

tests/misc/projects/Issue6525/compile-fail.hxml

@@ -0,0 +1 @@
+-main Main

tests/misc/projects/Issue6525/compile-fail.hxml.stderr

@@ -0,0 +1,2 @@
+Main.hx:14: characters 3-16 : Cannot access private field testPack
+Main.hx:15: characters 3-16 : Cannot access private field testPack

tests/misc/projects/Issue6525/pack/BasePack.hx

@@ -0,0 +1,12 @@
+package pack;
+
+import pack.Pvt;
+
+class BasePack {
+	public function new() {}
+
+	public function test() {
+		Pvt1.testPack();
+		Pvt2.testPack();
+	}
+}

tests/misc/projects/Issue6525/pack/IPack.hx

@@ -0,0 +1,3 @@
+package pack;
+
+interface IPack {}

tests/misc/projects/Issue6525/pack/Pvt.hx

@@ -0,0 +1,17 @@
+package pack;
+
+@:allow(pack)
+class Pvt1 {
+	static function testPack() {}
+}
+
+class Pvt2 {
+	@:allow(pack)
+	static function testPack() {}
+
+	@:allow(pack.BasePack)
+	static function testClass() {}
+
+	@:allow(pack.IPack)
+	static function testInterface() {}
+}