lib/bigrat.pl
lib/blib.pm
lib/cacheout.pl
+lib/charnames.pm ilya
lib/chat2.pl
lib/complete.pl
lib/constant.pm
t/lib/cgi-function.t
t/lib/cgi-html.t
t/lib/cgi-request.t
+t/lib/charnames.t ilya
t/lib/checktree.t
t/lib/complex.t complex
t/lib/db-btree.t pmarquess
lib/blib.pm For "use blib"
lib/cacheout.pl Manages output filehandles when you need too many
lib/caller.pm Inherit pragmatic attributes from caller's context
+lib/charnames.pm Character names
lib/chat2.pl Obsolete ipc library (use Comm.pm etc instead)
lib/complete.pl A command completion subroutine
lib/constant.pm For "use constant"
t/lib/cgi-function.t See if CGI.pm works
t/lib/cgi-html.t See if CGI.pm works
t/lib/cgi-request.t See if CGI.pm works
+t/lib/charnames.t See if character names work
t/lib/checktree.t See if File::CheckTree works
t/lib/complex.t See if Math::Complex works
t/lib/db-btree.t See if DB_File works
--- /dev/null
+package charnames;
+
+my $fname = 'unicode/UnicodeData-Latest.txt';
+my $txt;
+
+# This is not optimized in any way yet
+sub charnames {
+ $name = shift;
+ $txt = do "unicode/Name.pl" unless $txt;
+ my @off;
+ if ($^H{charnames_full} and $txt =~ /\t\t$name$/m) {
+ @off = ($-[0], $+[0]);
+ }
+ unless (@off) {
+ if ($^H{charnames_short} and $name =~ /^(.*?):(.*)/s) {
+ my ($script, $cname) = ($1,$2);
+ my $case = ( $cname =~ /[[:upper:]]/ ? "CAPITAL" : "SMALL");
+ if ($txt =~ m/\t\t\U$script\E (?:$case )?LETTER \U$cname$/m) {
+ @off = ($-[0], $+[0]);
+ }
+ }
+ }
+ unless (@off) {
+ my $case = ( $name =~ /[[:upper:]]/ ? "CAPITAL" : "SMALL");
+ for ( @{$^H{charnames_scripts}} ) {
+ (@off = ($-[0], $+[0])), last
+ if $txt =~ m/\t\t$_ (?:$case )?LETTER \U$name$/m;
+ }
+ }
+ die "Unknown charname '$name'" unless @off;
+
+ # use caller 'encoding'; # Does not work at compile time?
+
+ my $ord = hex substr $txt, $off[0] - 4, 4;
+ if ($^H & 0x8) {
+ use utf8;
+ return chr $ord;
+ }
+ return chr $ord if $ord <= 255;
+ my $hex = sprintf '%X=0%o', $ord, $ord;
+ my $fname = substr $txt, $off[0] + 2, $off[1] - $off[0] - 2;
+ die "Character 0x$hex with name '$fname' is above 0xFF";
+}
+
+sub import {
+ shift;
+ die "No scripts for `use charnames'" unless @_;
+ $^H |= 0x20000;
+ $^H{charnames} = \&charnames ;
+ my %h;
+ @h{@_} = (1) x @_;
+ $^H{charnames_full} = delete $h{':full'};
+ $^H{charnames_short} = delete $h{':short'};
+ $^H{charnames_scripts} = [map uc, keys %h];
+}
+
+
+1;
+__END__
+
+=head1 NAME
+
+charnames - define character names for C<\C{named}> string literal escape.
+
+=head1 SYNOPSIS
+
+ use charnames ':full';
+ print "\C{GREEK SMALL LETTER SIGMA} is called sigma.\n";
+
+ use charnames ':short';
+ print "\C{greek:Sigma} is an upper-case sigma.\n";
+
+ use charnames qw(cyrillic greek);
+ print "\C{sigma} is Greek sigma, and \C{be} is Cyrillic b.\n";
+
+=head1 DESCRIPTION
+
+Pragma C<use charnames> supports arguments C<:full>, C<:short> and
+script names. If C<:full> is present, for expansion of
+C<\C{CHARNAME}}> string C<CHARNAME> is first looked in the list of
+standard Unicode names of chars. If C<:short> is present, and
+C<CHARNAME> has the form C<SCRIPT:CNAME>, then C<CNAME> is looked up
+as a letter in script C<SCRIPT>. If pragma C<use charnames> is used
+with script name arguments, then for C<\C{CHARNAME}}> the name
+C<CHARNAME> is looked up as a letter in the given scripts (in the
+specified order).
+
+For lookup of C<CHARNAME> inside a given script C<SCRIPTNAME>
+F<charcodes.pm> looks for the names
+
+ SCRIPTNAME CAPITAL LETTER CHARNAME
+ SCRIPTNAME SMALL LETTER CHARNAME
+ SCRIPTNAME LETTER CHARNAME
+
+in the table of standard Unicode names. If C<CHARNAME> is lowercase,
+then the C<CAPITAL> variant is ignored, otherwise C<SMALL> variant is
+ignored.
+
+=head1 CUSTOM TRANSLATORS
+
+The mechanism of translation is C<\C{...}> escapes is general and not
+hardwired into F<charnames.pm>. A module can install custom
+translations (inside the scope which C<use>s the module) by the
+following magic incantation:
+
+ sub import {
+ shift;
+ $^H |= 0x20000;
+ $^H{charnames} = \&translator;
+ }
+
+Here translator() is a subroutine which takes C<CHARNAME> as an
+argument, and returns text to insert into the string instead of the
+C<\C{CHARNAME}> escape. Since the text to insert should be different
+in C<utf8> mode and out of it, the function should check the current
+state of C<utf8>-flag as in
+
+ sub translator {
+ if ($^H & 0x8) {
+ return utf_translator(@_);
+ } else {
+ return no_utf_translator(@_);
+ }
+ }
+
+=head1 BUGS
+
+Since evaluation of the translation function happens in a middle of
+compilation (of a string literal), the translation function should not
+do any C<eval>s or C<require>s. This restriction should be lifted in
+a future version of Perl.
+
+=cut
+
=item *
Regular expressions match characters instead of bytes. For instance,
-"." matches a character instead of a byte. (However, the C<\C> pattern
-is provided to force a match a single byte ("C<char>" in C, hence
-C<\C>).)
+"." matches a character instead of a byte. (However, the C<\O> pattern
+is provided to force a match a single byte ("octet", hence C<\O>).)
=item *
inlining. See L<perlsub/"Constant Functions"> for commentary and
workarounds.
+=item constant(%s): %%^H is not localized
+
+(F) When setting compile-time-lexicalized hash %^H one should set the
+corresponding bit of $^H as well.
+
+=item constant(%s): %s
+
+(F) Compile-time-substitutions (such as overloaded constants and
+character names) were not correctly set up.
+
=item Copy method did not return a reference
(F) The method which overloads "=" is buggy. See L<overload/Copy Constructor>.
mentioned with the $ in Perl, unlike in the shells, where it can vary from
one line to the next.
+=item Missing %sbrace%s on \C{}
+
+(F) Wrong syntax of character name literal C<\C{charname}> within
+double-quotish context.
+
=item Missing comma after first argument to %s function
(F) While certain functions allow you to specify a filehandle or an
\x1b hex char (ESC)
\x{263a} wide hex char (SMILEY)
\c[ control char (ESC)
+ \C{name} named char
\l lowercase next char
\u uppercase next char
\Q quote non-word characters till \E
If C<use locale> is in effect, the case map used by C<\l>, C<\L>, C<\u>
-and C<\U> is taken from the current locale. See L<perllocale>.
+and C<\U> is taken from the current locale. See L<perllocale>. For
+documentation of C<\C{name}>, see L<charnames>.
All systems use the virtual C<"\n"> to represent a line terminator,
called a "newline". There is no such thing as an unvarying, physical
\x1B hex char
\x{263a} wide hex char (Unicode SMILEY)
\c[ control char
+ \C{name} named char
\l lowercase next char (think vi)
\u uppercase next char (think vi)
\L lowercase till \E (think vi)
\Q quote (disable) pattern metacharacters till \E
If C<use locale> is in effect, the case map used by C<\l>, C<\L>, C<\u>
-and C<\U> is taken from the current locale. See L<perllocale>.
+and C<\U> is taken from the current locale. See L<perllocale>. For
+documentation of C<\C{name}>, see L<charnames>.
You cannot include a literal C<$> or C<@> within a C<\Q> sequence.
An unescaped C<$> or C<@> interpolates the corresponding variable,
\PP Match non-P
\X Match eXtended Unicode "combining character sequence",
equivalent to C<(?:\PM\pM*)>
- \C Match a single C char (octet) even under utf8.
+ \O Match a single C char (octet) even under utf8.
A C<\w> matches a single alphanumeric character, not a whole word.
Use C<\w+> to match a string of Perl-identifier characters (which isn't
PL_seen_zerolen++; /* Do not optimize RE away */
nextchar();
break;
- case 'C':
+ case 'O':
ret = reg_node(SANY);
*flagp |= HASWIDTH|SIMPLE;
nextchar();
--- /dev/null
+#!./perl
+
+BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ unshift @INC, '../lib' if -d '../lib';
+ }
+}
+
+$| = 1;
+print "1..5\n";
+
+use charnames ':full';
+
+print "not " unless "Here\C{EXCLAMATION MARK}?" eq 'Here!?';
+print "ok 1\n";
+
+print "# \$res=$res \$\@='$@'\nnot "
+ if $res = eval <<'EOE'
+use charnames ":full";
+"Here: \C{CYRILLIC SMALL LETTER BE}!";
+1
+EOE
+ or $@ !~ /above 0xFF/;
+print "ok 2\n";
+# print "# \$res=$res \$\@='$@'\n";
+
+print "# \$res=$res \$\@='$@'\nnot "
+ if $res = eval <<'EOE'
+use charnames 'cyrillic';
+"Here: \C{Be}!";
+1
+EOE
+ or $@ !~ /CYRILLIC CAPITAL LETTER BE.*above 0xFF/;
+print "ok 3\n";
+
+# If octal representation of unicode char is \0xyzt, then the utf8 is \3xy\2zt
+$encoded_be = "\320\261";
+$encoded_alpha = "\316\261";
+$encoded_bet = "\327\221";
+{
+ use charnames ':full';
+ use utf8;
+
+ print "not " unless "\C{CYRILLIC SMALL LETTER BE}" eq $encoded_be;
+ print "ok 4\n";
+
+ use charnames qw(cyrillic greek :short);
+
+ print "not " unless "\C{be},\C{alpha},\C{hebrew:bet}"
+ eq "$encoded_be,$encoded_alpha,$encoded_bet";
+ print "ok 5\n";
+}
: UTF;
char *leaveit = /* set of acceptably-backslashed characters */
PL_lex_inpat
- ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
+ ? "\\.^$@AGZdDwWsSbBpPXO+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
: "";
while (s < send || dorange) {
}
continue;
+ /* \C{latin small letter a} is a named character */
+ case 'C':
+ ++s;
+ if (*s == '{') {
+ char* e = strchr(s, '}');
+ HV *hv;
+ SV **svp;
+ SV *res, *cv;
+ STRLEN len;
+ char *str;
+ char *why = Nullch;
+
+ if (!e) {
+ yyerror("Missing right brace on \\C{}");
+ e = s - 1;
+ goto cont_scan;
+ }
+ res = newSVpvn(s + 1, e - s - 1);
+ res = new_constant( Nullch, 0, "charnames",
+ res, Nullsv, "\\C{...}" );
+ str = SvPV(res,len);
+ if (len > e - s + 4) {
+ char *odest = SvPVX(sv);
+
+ SvGROW(sv, (SvCUR(sv) + len - (e - s + 4)));
+ d = SvPVX(sv) + (d - odest);
+ }
+ Copy(str, d, len, char);
+ d += len;
+ SvREFCNT_dec(res);
+ cont_scan:
+ s = e + 1;
+ }
+ else
+ yyerror("Missing braces on \\C{}");
+ continue;
+
/* \c is a control character */
case 'c':
s++;
}
}
+/* Either returns sv, or mortalizes sv and returns a new SV*.
+ Best used as sv=new_constant(..., sv, ...).
+ If s, pv are NULL, calls subroutine with one argument,
+ and type is used with error messages only. */
+
STATIC SV *
S_new_constant(pTHX_ char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
{
dSP;
HV *table = GvHV(PL_hintgv); /* ^H */
- BINOP myop;
SV *res;
- bool oldcatch = CATCH_GET;
SV **cvp;
SV *cv, *typesv;
-
+ char *why, *why1, *why2;
+
+ if (!(PL_hints & HINT_LOCALIZE_HH)) {
+ SV *msg;
+
+ why = "%^H is not localized";
+ report_short:
+ why1 = why2 = "";
+ report:
+ msg = Perl_newSVpvf(aTHX_ "constant(%s): %s%s%s",
+ (type ? type: "undef"), why1, why2, why);
+ yyerror(SvPVX(msg));
+ SvREFCNT_dec(msg);
+ return sv;
+ }
if (!table) {
- yyerror("%^H is not defined");
- return sv;
+ why = "%^H is not defined";
+ goto report_short;
}
cvp = hv_fetch(table, key, strlen(key), FALSE);
if (!cvp || !SvOK(*cvp)) {
- char buf[128];
- sprintf(buf,"$^H{%s} is not defined", key);
- yyerror(buf);
- return sv;
+ why = "} is not defined";
+ why1 = "$^H{";
+ why2 = key;
+ goto report;
}
sv_2mortal(sv); /* Parent created it permanently */
cv = *cvp;
- if (!pv)
- pv = sv_2mortal(newSVpvn(s, len));
- if (type)
- typesv = sv_2mortal(newSVpv(type, 0));
+ if (!pv && s)
+ pv = sv_2mortal(newSVpvn(s, len));
+ if (type && pv)
+ typesv = sv_2mortal(newSVpv(type, 0));
else
- typesv = &PL_sv_undef;
- CATCH_SET(TRUE);
- Zero(&myop, 1, BINOP);
- myop.op_last = (OP *) &myop;
- myop.op_next = Nullop;
- myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
-
+ typesv = &PL_sv_undef;
+
PUSHSTACKi(PERLSI_OVERLOAD);
- ENTER;
- SAVEOP();
- PL_op = (OP *) &myop;
- if (PERLDB_SUB && PL_curstash != PL_debstash)
- PL_op->op_private |= OPpENTERSUB_DB;
- PUTBACK;
- Perl_pp_pushmark(aTHX);
-
+ ENTER ;
+ SAVETMPS;
+
+ PUSHMARK(SP) ;
EXTEND(sp, 4);
- PUSHs(pv);
+ if (pv)
+ PUSHs(pv);
PUSHs(sv);
- PUSHs(typesv);
+ if (pv)
+ PUSHs(typesv);
PUSHs(cv);
PUTBACK;
-
- if (PL_op = Perl_pp_entersub(aTHX))
- CALLRUNOPS(aTHX);
- LEAVE;
- SPAGAIN;
-
- res = POPs;
- PUTBACK;
- CATCH_SET(oldcatch);
+ call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
+
+ SPAGAIN ;
+
+ /* Check the eval first */
+ if (!PL_in_eval && SvTRUE(ERRSV))
+ {
+ STRLEN n_a;
+ sv_catpv(ERRSV, "Propagated");
+ yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */
+ POPs ;
+ res = SvREFCNT_inc(sv);
+ }
+ else {
+ res = POPs;
+ SvREFCNT_inc(res);
+ }
+
+ PUTBACK ;
+ FREETMPS ;
+ LEAVE ;
POPSTACK;
-
+
if (!SvOK(res)) {
- char buf[128];
- sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
- yyerror(buf);
- }
- return SvREFCNT_inc(res);
+ why = "}} did not return a defined value";
+ why1 = "Call to &{$^H{";
+ why2 = key;
+ sv = res;
+ goto report;
+ }
+
+ return res;
}
-
+
STATIC char *
S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
{
projects / platform / upstream / perl.git / commitdiff