require 5;
# The documentation is at the end.
# Time-stamp: "2004-05-07 15:31:25 ADT"
package Pod::Escapes;
require Exporter;
@ISA = ('Exporter');
$VERSION = '1.04';
@EXPORT_OK = qw(
%Code2USASCII
%Name2character
%Name2character_number
%Latin1Code_to_fallback
%Latin1Char_to_fallback
e2char
e2charnum
);
%EXPORT_TAGS = ('ALL' => \@EXPORT_OK);
#==========================================================================
use strict;
use vars qw(
%Code2USASCII
%Name2character
%Name2character_number
%Latin1Code_to_fallback
%Latin1Char_to_fallback
$FAR_CHAR
$FAR_CHAR_NUMBER
$NOT_ASCII
);
$FAR_CHAR = "?" unless defined $FAR_CHAR;
$FAR_CHAR_NUMBER = ord($FAR_CHAR) unless defined $FAR_CHAR_NUMBER;
$NOT_ASCII = 'A' ne chr(65) unless defined $NOT_ASCII;
#--------------------------------------------------------------------------
sub e2char {
my $in = $_[0];
return undef unless defined $in and length $in;
# Convert to decimal:
if($in =~ m/^(0[0-7]*)$/s ) {
$in = oct $in;
} elsif($in =~ m/^0?x([0-9a-fA-F]+)$/s ) {
$in = hex $1;
} # else it's decimal, or named
if($NOT_ASCII) {
# We're in bizarro world of not-ASCII!
# Cope with US-ASCII codes, use fallbacks for Latin-1, or use FAR_CHAR.
unless($in =~ m/^\d+$/s) {
# It's a named character reference. Get its numeric Unicode value.
$in = $Name2character{$in};
return undef unless defined $in; # (if there's no such name)
$in = ord $in; # (All ents must be one character long.)
# ...So $in holds the char's US-ASCII numeric value, which we'll
# now go get the local equivalent for.
}
# It's numeric, whether by origin or by mutation from a known name
return $Code2USASCII{$in} # so "65" => "A" everywhere
|| $Latin1Code_to_fallback{$in} # Fallback.
|| $FAR_CHAR; # Fall further back
}
# Normal handling:
if($in =~ m/^\d+$/s) {
if($] < 5.007 and $in > 255) { # can't be trusted with Unicode
return $FAR_CHAR;
} else {
return chr($in);
}
} else {
return $Name2character{$in}; # returns undef if unknown
}
}
#--------------------------------------------------------------------------
sub e2charnum {
my $in = $_[0];
return undef unless defined $in and length $in;
# Convert to decimal:
if($in =~ m/^(0[0-7]*)$/s ) {
$in = oct $in;
} elsif($in =~ m/^0?x([0-9a-fA-F]+)$/s ) {
$in = hex $1;
} # else it's decimal, or named
if($in =~ m/^\d+$/s) {
return 0 + $in;
} else {
return $Name2character_number{$in}; # returns undef if unknown
}
}
#--------------------------------------------------------------------------
%Name2character_number = (
# General XML/XHTML:
'lt' => 60,
'gt' => 62,
'quot' => 34,
'amp' => 38,
'apos' => 39,
# POD-specific:
'sol' => 47,
'verbar' => 124,
'lchevron' => 171, # legacy for laquo
'rchevron' => 187, # legacy for raquo
# Remember, grave looks like \ (as in virtu\)
# acute looks like / (as in re/sume/)
# circumflex looks like ^ (as in papier ma^che/)
# umlaut/dieresis looks like " (as in nai"ve, Chloe")
# From the XHTML 1 .ent files:
'nbsp' , 160,
'iexcl' , 161,
'cent' , 162,
'pound' , 163,
'curren' , 164,
'yen' , 165,
'brvbar' , 166,
'sect' , 167,
'uml' , 168,
'copy' , 169,
'ordf' , 170,
'laquo' , 171,
'not' , 172,
'shy' , 173,
'reg' , 174,
'macr' , 175,
'deg' , 176,
'plusmn' , 177,
'sup2' , 178,
'sup3' , 179,
'acute' , 180,
'micro' , 181,
'para' , 182,
'middot' , 183,
'cedil' , 184,
'sup1' , 185,
'ordm' , 186,
'raquo' , 187,
'frac14' , 188,
'frac12' , 189,
'frac34' , 190,
'iquest' , 191,
'Agrave' , 192,
'Aacute' , 193,
'Acirc' , 194,
'Atilde' , 195,
'Auml' , 196,
'Aring' , 197,
'AElig' , 198,
'Ccedil' , 199,
'Egrave' , 200,
'Eacute' , 201,
'Ecirc' , 202,
'Euml' , 203,
'Igrave' , 204,
'Iacute' , 205,
'Icirc' , 206,
'Iuml' , 207,
'ETH' , 208,
'Ntilde' , 209,
'Ograve' , 210,
'Oacute' , 211,
'Ocirc' , 212,
'Otilde' , 213,
'Ouml' , 214,
'times' , 215,
'Oslash' , 216,
'Ugrave' , 217,
'Uacute' , 218,
'Ucirc' , 219,
'Uuml' , 220,
'Yacute' , 221,
'THORN' , 222,
'szlig' , 223,
'agrave' , 224,
'aacute' , 225,
'acirc' , 226,
'atilde' , 227,
'auml' , 228,
'aring' , 229,
'aelig' , 230,
'ccedil' , 231,
'egrave' , 232,
'eacute' , 233,
'ecirc' , 234,
'euml' , 235,
'igrave' , 236,
'iacute' , 237,
'icirc' , 238,
'iuml' , 239,
'eth' , 240,
'ntilde' , 241,
'ograve' , 242,
'oacute' , 243,
'ocirc' , 244,
'otilde' , 245,
'ouml' , 246,
'divide' , 247,
'oslash' , 248,
'ugrave' , 249,
'uacute' , 250,
'ucirc' , 251,
'uuml' , 252,
'yacute' , 253,
'thorn' , 254,
'yuml' , 255,
'fnof' , 402,
'Alpha' , 913,
'Beta' , 914,
'Gamma' , 915,
'Delta' , 916,
'Epsilon' , 917,
'Zeta' , 918,
'Eta' , 919,
'Theta' , 920,
'Iota' , 921,
'Kappa' , 922,
'Lambda' , 923,
'Mu' , 924,
'Nu' , 925,
'Xi' , 926,
'Omicron' , 927,
'Pi' , 928,
'Rho' , 929,
'Sigma' , 931,
'Tau' , 932,
'Upsilon' , 933,
'Phi' , 934,
'Chi' , 935,
'Psi' , 936,
'Omega' , 937,
'alpha' , 945,
'beta' , 946,
'gamma' , 947,
'delta' , 948,
'epsilon' , 949,
'zeta' , 950,
'eta' , 951,
'theta' , 952,
'iota' , 953,
'kappa' , 954,
'lambda' , 955,
'mu' , 956,
'nu' , 957,
'xi' , 958,
'omicron' , 959,
'pi' , 960,
'rho' , 961,
'sigmaf' , 962,
'sigma' , 963,
'tau' , 964,
'upsilon' , 965,
'phi' , 966,
'chi' , 967,
'psi' , 968,
'omega' , 969,
'thetasym' , 977,
'upsih' , 978,
'piv' , 982,
'bull' , 8226,
'hellip' , 8230,
'prime' , 8242,
'Prime' , 8243,
'oline' , 8254,
'frasl' , 8260,
'weierp' , 8472,
'image' , 8465,
'real' , 8476,
'trade' , 8482,
'alefsym' , 8501,
'larr' , 8592,
'uarr' , 8593,
'rarr' , 8594,
'darr' , 8595,
'harr' , 8596,
'crarr' , 8629,
'lArr' , 8656,
'uArr' , 8657,
'rArr' , 8658,
'dArr' , 8659,
'hArr' , 8660,
'forall' , 8704,
'part' , 8706,
'exist' , 8707,
'empty' , 8709,
'nabla' , 8711,
'isin' , 8712,
'notin' , 8713,
'ni' , 8715,
'prod' , 8719,
'sum' , 8721,
'minus' , 8722,
'lowast' , 8727,
'radic' , 8730,
'prop' , 8733,
'infin' , 8734,
'ang' , 8736,
'and' , 8743,
'or' , 8744,
'cap' , 8745,
'cup' , 8746,
'int' , 8747,
'there4' , 8756,
'sim' , 8764,
'cong' , 8773,
'asymp' , 8776,
'ne' , 8800,
'equiv' , 8801,
'le' , 8804,
'ge' , 8805,
'sub' , 8834,
'sup' , 8835,
'nsub' , 8836,
'sube' , 8838,
'supe' , 8839,
'oplus' , 8853,
'otimes' , 8855,
'perp' , 8869,
'sdot' , 8901,
'lceil' , 8968,
'rceil' , 8969,
'lfloor' , 8970,
'rfloor' , 8971,
'lang' , 9001,
'rang' , 9002,
'loz' , 9674,
'spades' , 9824,
'clubs' , 9827,
'hearts' , 9829,
'diams' , 9830,
'OElig' , 338,
'oelig' , 339,
'Scaron' , 352,
'scaron' , 353,
'Yuml' , 376,
'circ' , 710,
'tilde' , 732,
'ensp' , 8194,
'emsp' , 8195,
'thinsp' , 8201,
'zwnj' , 8204,
'zwj' , 8205,
'lrm' , 8206,
'rlm' , 8207,
'ndash' , 8211,
'mdash' , 8212,
'lsquo' , 8216,
'rsquo' , 8217,
'sbquo' , 8218,
'ldquo' , 8220,
'rdquo' , 8221,
'bdquo' , 8222,
'dagger' , 8224,
'Dagger' , 8225,
'permil' , 8240,
'lsaquo' , 8249,
'rsaquo' , 8250,
'euro' , 8364,
);
# Fill out %Name2character...
{
%Name2character = ();
my($name, $number);
while( ($name, $number) = each %Name2character_number) {
if($] < 5.007 and $number > 255) {
$Name2character{$name} = $FAR_CHAR;
# substitute for Unicode characters, for perls
# that can't reliable handle them
} else {
$Name2character{$name} = chr $number;
# normal case
}
}
# So they resolve 'right' even in EBCDIC-land
$Name2character{'lt' } = '<';
$Name2character{'gt' } = '>';
$Name2character{'quot'} = '"';
$Name2character{'amp' } = '&';
$Name2character{'apos'} = "'";
$Name2character{'sol' } = '/';
$Name2character{'verbar'} = '|';
}
#--------------------------------------------------------------------------
%Code2USASCII = (
# mostly generated by
# perl -e "printf qq{ \x25 3s, '\x25s',\n}, $_, chr($_) foreach (32 .. 126)"
32, ' ',
33, '!',
34, '"',
35, '#',
36, '$',
37, '%',
38, '&',
39, "'", #!
40, '(',
41, ')',
42, '*',
43, '+',
44, ',',
45, '-',
46, '.',
47, '/',
48, '0',
49, '1',
50, '2',
51, '3',
52, '4',
53, '5',
54, '6',
55, '7',
56, '8',
57, '9',
58, ':',
59, ';',
60, '<',
61, '=',
62, '>',
63, '?',
64, '@',
65, 'A',
66, 'B',
67, 'C',
68, 'D',
69, 'E',
70, 'F',
71, 'G',
72, 'H',
73, 'I',
74, 'J',
75, 'K',
76, 'L',
77, 'M',
78, 'N',
79, 'O',
80, 'P',
81, 'Q',
82, 'R',
83, 'S',
84, 'T',
85, 'U',
86, 'V',
87, 'W',
88, 'X',
89, 'Y',
90, 'Z',
91, '[',
92, "\\", #!
93, ']',
94, '^',
95, '_',
96, '`',
97, 'a',
98, 'b',
99, 'c',
100, 'd',
101, 'e',
102, 'f',
103, 'g',
104, 'h',
105, 'i',
106, 'j',
107, 'k',
108, 'l',
109, 'm',
110, 'n',
111, 'o',
112, 'p',
113, 'q',
114, 'r',
115, 's',
116, 't',
117, 'u',
118, 'v',
119, 'w',
120, 'x',
121, 'y',
122, 'z',
123, '{',
124, '|',
125, '}',
126, '~',
);
#--------------------------------------------------------------------------
%Latin1Code_to_fallback = ();
@Latin1Code_to_fallback{0xA0 .. 0xFF} = (
# Copied from Text/Unidecode/x00.pm:
' ', qq{!}, qq{C/}, 'PS', qq{\$?}, qq{Y=}, qq{|}, 'SS', qq{"}, qq{(c)}, 'a', qq{<<}, qq{!}, "", qq{(r)}, qq{-},
'deg', qq{+-}, '2', '3', qq{'}, 'u', 'P', qq{*}, qq{,}, '1', 'o', qq{>>}, qq{1/4}, qq{1/2}, qq{3/4}, qq{?},
'A', 'A', 'A', 'A', 'A', 'A', 'AE', 'C', 'E', 'E', 'E', 'E', 'I', 'I', 'I', 'I',
'D', 'N', 'O', 'O', 'O', 'O', 'O', 'x', 'O', 'U', 'U', 'U', 'U', 'U', 'Th', 'ss',
'a', 'a', 'a', 'a', 'a', 'a', 'ae', 'c', 'e', 'e', 'e', 'e', 'i', 'i', 'i', 'i',
'd', 'n', 'o', 'o', 'o', 'o', 'o', qq{/}, 'o', 'u', 'u', 'u', 'u', 'y', 'th', 'y',
);
{
# Now stuff %Latin1Char_to_fallback:
%Latin1Char_to_fallback = ();
my($k,$v);
while( ($k,$v) = each %Latin1Code_to_fallback) {
$Latin1Char_to_fallback{chr $k} = $v;
#print chr($k), ' => ', $v, "\n";
}
}
#--------------------------------------------------------------------------
1;
__END__
=head1 NAME
Pod::Escapes -- for resolving Pod EE<lt>...E<gt> sequences
=head1 SYNOPSIS
use Pod::Escapes qw(e2char);
...la la la, parsing POD, la la la...
$text = e2char($e_node->label);
unless(defined $text) {
print "Unknown E sequence \"", $e_node->label, "\"!";
}
...else print/interpolate $text...
=head1 DESCRIPTION
This module provides things that are useful in decoding
Pod EE<lt>...E<gt> sequences. Presumably, it should be used
only by Pod parsers and/or formatters.
By default, Pod::Escapes exports none of its symbols. But
you can request any of them to be exported.
Either request them individually, as with
C<use Pod::Escapes qw(symbolname symbolname2...);>,
or you can do C<use Pod::Escapes qw(:ALL);> to get all
exportable symbols.
=head1 GOODIES
=over
=item e2char($e_content)
Given a name or number that could appear in a
C<EE<lt>name_or_numE<gt>> sequence, this returns the string that
it stands for. For example, C<e2char('sol')>, C<e2char('47')>,
C<e2char('0x2F')>, and C<e2char('057')> all return "/",
because C<EE<lt>solE<gt>>, C<EE<lt>47E<gt>>, C<EE<lt>0x2fE<gt>>,
and C<EE<lt>057E<gt>>, all mean "/". If
the name has no known value (as with a name of "qacute") or is
syntactally invalid (as with a name of "1/4"), this returns undef.
=item e2charnum($e_content)
Given a name or number that could appear in a
C<EE<lt>name_or_numE<gt>> sequence, this returns the number of
the Unicode character that this stands for. For example,
C<e2char('sol')>, C<e2char('47')>,
C<e2char('0x2F')>, and C<e2char('057')> all return 47,
because C<EE<lt>solE<gt>>, C<EE<lt>47E<gt>>, C<EE<lt>0x2fE<gt>>,
and C<EE<lt>057E<gt>>, all mean "/", whose Unicode number is 47. If
the name has no known value (as with a name of "qacute") or is
syntactally invalid (as with a name of "1/4"), this returns undef.
=item $Name2character{I<name>}
Maps from names (as in C<EE<lt>I<name>E<gt>>) like "eacute" or "sol"
to the string that each stands for. Note that this does not
include numerics (like "64" or "x981c"). Under old Perl versions
(before 5.7) you get a "?" in place of characters whose Unicode
value is over 255.
=item $Name2character_number{I<name>}
Maps from names (as in C<EE<lt>I<name>E<gt>>) like "eacute" or "sol"
to the Unicode value that each stands for. For example,
C<$Name2character_number{'eacute'}> is 201, and
C<$Name2character_number{'eacute'}> is 8364. You get the correct
Unicode value, regardless of the version of Perl you're using --
which differs from C<%Name2character>'s behavior under pre-5.7 Perls.
Note that this hash does not
include numerics (like "64" or "x981c").
=item $Latin1Code_to_fallback{I<integer>}
For numbers in the range 160 (0x00A0) to 255 (0x00FF), this maps
from the character code for a Latin-1 character (like 233 for
lowercase e-acute) to the US-ASCII character that best aproximates
it (like "e"). You may find this useful if you are rendering
POD in a format that you think deals well only with US-ASCII
characters.
=item $Latin1Char_to_fallback{I<character>}
Just as above, but maps from characters (like "\xE9",
lowercase e-acute) to characters (like "e").
=item $Code2USASCII{I<integer>}
This maps from US-ASCII codes (like 32) to the corresponding
character (like space, for 32). Only characters 32 to 126 are
defined. This is meant for use by C<e2char($x)> when it senses
that it's running on a non-ASCII platform (where chr(32) doesn't
get you a space -- but $Code2USASCII{32} will). It's
documented here just in case you might find it useful.
=back
=head1 CAVEATS
On Perl versions before 5.7, Unicode characters with a value
over 255 (like lambda or emdash) can't be conveyed. This
module does work under such early Perl versions, but in the
place of each such character, you get a "?". Latin-1
characters (characters 160-255) are unaffected.
Under EBCDIC platforms, C<e2char($n)> may not always be the
same as C<chr(e2charnum($n))>, and ditto for
C<$Name2character{$name}> and
C<chr($Name2character_number{$name})>.
=head1 SEE ALSO
L<perlpod|perlpod>
L<perlpodspec|perlpodspec>
L<Text::Unidecode|Text::Unidecode>
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2001-2004 Sean M. Burke. All rights reserved.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
Portions of the data tables in this module are derived from the
entity declarations in the W3C XHTML specification.
Currently (October 2001), that's these three:
http://www.w3.org/TR/xhtml1/DTD/xhtml-lat1.ent
http://www.w3.org/TR/xhtml1/DTD/xhtml-special.ent
http://www.w3.org/TR/xhtml1/DTD/xhtml-symbol.ent
=head1 AUTHOR
Sean M. Burke C<sburke@cpan.org>
=cut
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# What I used for reading the XHTML .ent files:
use strict;
my(@norms, @good, @bad);
my $dir = 'c:/sgml/docbook/';
my %escapes;
foreach my $file (qw(
xhtml-symbol.ent
xhtml-lat1.ent
xhtml-special.ent
)) {
open(IN, "<$dir$file") or die "can't read-open $dir$file: $!";
print "Reading $file...\n";
while(<IN>) {
if(m/<!ENTITY\s+(\S+)\s+"&#([^;]+);">/) {
my($name, $value) = ($1,$2);
next if $name eq 'quot' or $name eq 'apos' or $name eq 'gt';
$value = hex $1 if $value =~ m/^x([a-fA-F0-9]+)$/s;
print "ILLEGAL VALUE $value" unless $value =~ m/^\d+$/s;
if($value > 255) {
push @good , sprintf " %-10s , chr(%s),\n", "'$name'", $value;
push @bad , sprintf " %-10s , \$bad,\n", "'$name'", $value;
} else {
push @norms, sprintf " %-10s , chr(%s),\n", "'$name'", $value;
}
} elsif(m/<!ENT/) {
print "# Skipping $_";
}
}
close(IN);
}
print @norms;
print "\n ( \$] .= 5.006001 ? (\n";
print @good;
print " ) : (\n";
print @bad;
print " )\n);\n";
__END__
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~