Nat Torkington had an approach like yours, probably in the Perl Cookbook. I offer a much simpler solution:

s/(old)/preserve_case("new", $1)/ieg;

sub preserve_case {
  my ($to, $from) = @_;
  die "strings don't match in length" unless length($to) == length($fr
+om);
  my $mask = $from & (' ' x length($from));
  return uc($to) | $mask;
}
[download]

Update: it works by creating a mask of NULs and spaces from the "from" string ("OlD" maps to "NUL SP NUL"). Then, it turns the "to" string to uppercase, and bitwise ORs the mask onto it ("NEW" & "\x00\x20\x00" is "NeW").

Golfing it:

# requires $" hasn't been altered
#       123456789_123456789_12345678 = 28
sub pc {uc$_[0]|$_[1]&$"x length pop}
[download]

Update 2: if you use this to change "ThIs{" to "ThAt[", you'll end up getting "ThAt{", because of the bitwise operations. This is a side effect of the unprejudiced ANDing. It can be "fixed" like so (this, and the corresponding golf, are locale sensitive):

sub preserve_case {
  my ($to, $from) = @_;
  die "strings don't match in length" unless length($to) == length($fr
+om);
  my $mask = join '', map /\w/ ? $_ & ' ' : "\0", split //, $from;
  return uc($to) | $mask;
}
[download]

An alternative to the $mask creation is to use a regex:

(my $mask = $from) =~ s/(\w)|./ $1 ? $1 & ' ' : "\0" /egs;
[download]

Golfing that, I get:

# requires $" hasn't been altered
#       123456789_123456789_123456789_123456789_123456789_ = 50
sub pc {(my$x=pop)=~s/(\w)|./$1?$1&' ':"\0"/egs;uc$_[0]|$x}
[download]

Update 3: another fix, to account for changing "a" to "BcDe", and for changing "AbCd" to "e":

sub preserve_case {
  my ($to, $from) = @_;
  my $len = length $to;

  if ($len < length $from) { $from = substr $from, 0, $len }
  else { $from .= substr $to, length($from) }

  (my $mask = $from) =~ s{(\w)|.}{ $1 ? $1 & ' ' : "\0" }egs;

  return uc($to) | $mask;
}
[download]

Update 4: Larry Rosler has code in the FAQ for this, and I've found faster way to form the mask from it:

sub preserve_case {
  my ($to, $from) = @_;
  my $len = length $to;

  if ($len < length $from) { $from = substr $from, 0, $len }
  else { $from .= substr $to, length($from) }

  return uc($to) | ($from ^ uc $from);
}
[download]

This works slightly differently from Larry's code. His code turns a "TeSt" => "succesS" to "SuCcESS", whereas mine preserves the case of the new word, if it's longer than the original ("SuCcesS").

japhy -- Perl and Regex Hacker