Implement the fc keyword and the \F string escape.

Along with the simple_casefolding and full_casefolding features.

fc() stands for foldcase, a sort of pseudo case (like lowercase),
which is used to implement Unicode casefolding. It maps a string
to a form where all case differences are erased, so it's a
locale-independent way of checking if two strings are the same,
regardless of case.

This functionality was, and still is, available through the
regular expression engine -- /i matches would use casefolding
internally. The fc keyword merely exposes this for easier access.

Previously, one could attempt to case-insensitively test two strings
for equality by doing

   lc($a) eq lc($b)

But that might get you wrong results, for example in the case of
\x{DF}, LATIN SMALL LETTER SHARP S.

3 files changed, 11 insertions, 4 deletions

diff --git a/dist/B-Deparse/Deparse.pm b/dist/B-Deparse/Deparse.pm
index 296be02f84..054b919e38 100644
--- a/dist/B-Deparse/Deparse.pm
+++ b/dist/B-Deparse/Deparse.pm
@@ -20,7 +20,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
          CVf_METHOD CVf_LVALUE
 	 PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
 	 PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
-$VERSION = "1.11";
+$VERSION = "1.12";
 use strict;
 use vars qw/$AUTOLOAD/;
 use warnings ();
@@ -1674,6 +1674,7 @@ my %feature_keywords = (
     break   => 'switch',
     evalbytes=>'evalbytes',
     __SUB__ => '__SUB__',
+   fc       => 'fc',
 );
 
 sub keyword {
@@ -2147,6 +2148,7 @@ sub pp_lcfirst { dq_unop(@_, "lcfirst") }
 sub pp_uc { dq_unop(@_, "uc") }
 sub pp_lc { dq_unop(@_, "lc") }
 sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") }
+sub pp_fc { dq_unop(@_, "fc") }
 
 sub loopex {
     my $self = shift;
@@ -4116,6 +4118,8 @@ sub dq {
 	return '\l' . $self->dq($op->first->sibling);
     } elsif ($type eq "quotemeta") {
 	return '\Q' . $self->dq($op->first->sibling) . '\E';
+    } elsif ($type eq "fc") {
+	return '\F' . $self->dq($op->first->sibling) . '\E';
     } elsif ($type eq "join") {
 	return $self->deparse($op->last, 26); # was join($", @ary)
     } else {
@@ -4437,6 +4441,8 @@ sub re_dq {
 	return '\l' . $self->re_dq($op->first->sibling, $extended);
     } elsif ($type eq "quotemeta") {
 	return '\Q' . $self->re_dq($op->first->sibling, $extended) . '\E';
+    } elsif ($type eq "fc") {
+	return '\F' . $self->re_dq($op->first->sibling, $extended) . '\E';
     } elsif ($type eq "join") {
 	return $self->deparse($op->last, 26); # was join($", @ary)
     } else {
@@ -4454,7 +4460,7 @@ sub pure_string {
     if ($type eq 'const' || $type eq 'av2arylen') {
 	return 1;
     }
-    elsif ($type =~ /^[ul]c(first)?$/ || $type eq 'quotemeta') {
+    elsif ($type =~ /^(?:[ul]c(first)?|fc)$/ || $type eq 'quotemeta') {
 	return $self->pure_string($op->first->sibling);
     }
     elsif ($type eq 'join') {
diff --git a/dist/B-Deparse/t/core.t b/dist/B-Deparse/t/core.t
index f5952af89c..62ff862e04 100644
--- a/dist/B-Deparse/t/core.t
+++ b/dist/B-Deparse/t/core.t
@@ -21,7 +21,7 @@ my @nary = (
      [qw( abs alarm break chr cos chop close chdir chomp chmod chown
           chroot caller continue die dump exp exit exec endgrent
           endpwent endnetent endhostent endservent
-          endprotoent evalbytes fork glob
+          endprotoent evalbytes fc fork glob
           getppid getpwent getprotoent gethostent getnetent getservent
           getgrent getlogin getc gmtime hex int lc log lstat length
           lcfirst localtime mkdir ord oct pop quotemeta ref rand
@@ -31,7 +31,7 @@ my @nary = (
  # unary
      [qw( abs alarm bless binmode chr cos chop close chdir chomp
           chmod chown chroot closedir die do dump exp exit exec
-          each evalbytes fileno getpgrp getpwnam getpwuid getpeername
+          each evalbytes fc fileno getpgrp getpwnam getpwuid getpeername
           getprotobyname getprotobynumber gethostbyname
           getnetbyname getsockname getgrnam getgrgid
           getc glob gmtime hex int join keys kill lc
diff --git a/dist/B-Deparse/t/deparse.t b/dist/B-Deparse/t/deparse.t
index 2831981de7..cae808c1d0 100644
--- a/dist/B-Deparse/t/deparse.t
+++ b/dist/B-Deparse/t/deparse.t
@@ -870,6 +870,7 @@ CORE::given ($x) {
 }
 CORE::evalbytes '';
 () = CORE::__SUB__;
+() = CORE::fc $x;
 ####
 # feature features when feature has been disabled by use VERSION
 use feature (sprintf(":%vd", $^V));