Return to Answer

Using the example from Mr.Wizard,

Using the example from Mr.Wizard,

ClearAll[Scope2];
SetAttributes[Scope2, HoldAll];

Scope2[{globals:(_Symbol | _Set|_SetDelayed)...}, body_]:=
(
 (* Put globals into Global` or equivalent *)
 globals;

 With[{vars = getSymbols[body]}, Block[vars, body]]
)

ClearAll[Scope2];
SetAttributes[Scope2, HoldAll];

Scope2[{globals:(_Symbol | _Set|_SetDelayed)...}, body_]:=
(
 (* Put globals into Global` or equivalent *)
 globals;

 With[{vars = getSymbols[body]//DeleteDuplicates}, Block[vars, body]]
)

Version 2

which deals with nested Hold, and

ClearAll[getSymbols];
SetAttributes[getSymbols, HoldAllComplete];
getSymbols[(Set|SetDelayed|TagSet|TagSetDelayed)[a_Symbol,__]] := flatHold[a]
getSymbols[(Set|SetDelayed)[a_,_]] := 
 Cases[Unevaluated@a , 
  r_Symbol /; !MemberQ[Attributes[r], Protected|Locked|ReadProtected]:> flatHold[r], 
  {0, Infinity}, 1, Heads->True]

which gets the symbol that needs to be localized. The second form of getSymbols is as complicated as it is because of having to deal with SubValues, and the fact that Head@q[r][y] == q[r]. There is probably a better way, though. Unfortunately, it does not deal with UpSet or UpSetDelayed, which I leave as an exercise to whoever can come up with something.

ClearAll[Scope2];
SetAttributes[Scope2, HoldAll];

Scope2[{globals:(_Symbol | _Set|_SetDelayed)...}, body_]:=
Internal`InheritedBlock[{$ContextPath},
 (* Put globals into Global` or equivalent *)
 globals;

 With[{
  vars = Cases[
    Unevaluated@body, 
    s : _Set | _SetDelayed | _TagSet | _TagSetDelayed :> getSymbols[s], 
    Infinity] 
  },
  Quiet[
   Block[vars,body] /. flatHold[a__]:> Unevaluated[{a}], 
   Block::lvlist
  ]
 ]
]

x = 1;
y = 1;
Scope2[{x = 2},
 q[x_] := x^2;
 r /: q[r] := 5;
 {y = 2, a = 0, q[2], q[r]}
]

{x, y, a, r}
DownValues[q]
UpValues[r]
(* 
 {2, 0, 4, 5}
 {2, 1, a, r}
 {}
 {}
*)

Overview

Here's two functions that operate in a manner close to what you want. The first uses a locally defined context to provide the scoping. The second uses Block, and is likely closer to what you wish.

Version 1

Version 2

which deals with nested Hold, and to simplify things later

(scope:Block|Module)[flatHold[a__], body_] ^:= scope[{a}, body]

which allows us to do this:

Block[flatHold[a, b], a = 5; b = 6; {a, b}]
Module[flatHold[a, b], a = 5; b = 6; {a, b}]
(* 
 {5, 6}
 {5, 6}
*)

This works because Block and Module have the attribute HoldAll; an attribute of HoldAllComplete, however, would have prevented up-values from firing. Also, we need a method for acquiring the symbols we wish to localize:

ClearAll[getSymbols];
SetAttributes[getSymbols, HoldAllComplete];
getSymbols[(Set|SetDelayed|TagSet|TagSetDelayed)[a_Symbol,__]] := flatHold[a]
getSymbols[(Set|SetDelayed)[a_,_]] := 
 Cases[Unevaluated@a , 
  r_Symbol /; !MemberQ[Attributes[r], Protected|Locked|ReadProtected]:> flatHold[r], 
  {0, Infinity}, 1, Heads->True]
getSymbols[expr_] :=
 Cases[Unevaluated@expr,
  s:_Set | _SetDelayed |_TagSet | _TagSetDelayed:> getSymbols[s], Infinity]

The second form of getSymbols is as complicated as it is because of having to deal with SubValues, and the fact that Head@q[r][y] == q[r]. There is probably a better way, though. Unfortunately, it does not deal with UpSet or UpSetDelayed, which I leave as an exercise to whoever can come up with something. The third form allows the user to pass in an arbitrary expression.

ClearAll[Scope2];
SetAttributes[Scope2, HoldAll];

Scope2[{globals:(_Symbol | _Set|_SetDelayed)...}, body_]:=
(
 (* Put globals into Global` or equivalent *)
 globals;

 With[{vars = getSymbols[body]}, Block[vars, body]]
)

which for all practical purposes is a one liner. Which as you can see

x = 1;
y = 1;
Scope2[{x = 2},
 q[x_] := x^2;
 r /: q[r] := 5;
 {y = 2, a = 0, q[2], q[r]}
]

{x, y, a, r}
DownValues[q]
UpValues[r]
(* 
 {2, 0, 4, 5}
 {2, 1, a, r}
 {}
 {}
*)

OwnValues, DownValues, and some UpValues are localized to the body of Scope2.