https://perl5.git.perl.org / perl5.git / blame
| Commit | Line | Data |
|---|---|---|
| 44b3b9c7 | 1 | # |
| 2fd0906e | 2 | # $Id: GSM0338.pm,v 2.1 2008/05/07 20:56:05 dankogai Exp $ |
| 44b3b9c7 SP |
3 | # |
| 4 | package Encode::GSM0338; | |
| 5 | ||
| 6 | use strict; | |
| 7 | use warnings; | |
| 8 | use Carp; | |
| 9 | ||
| 10 | use vars qw($VERSION); | |
| 0263186c | 11 | $VERSION = do { my @r = ( q$Revision: 2.1 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r }; |
| 44b3b9c7 SP |
12 | |
| 13 | use Encode qw(:fallbacks); | |
| 14 | ||
| 15 | use base qw(Encode::Encoding); | |
| 16 | __PACKAGE__->Define('gsm0338'); | |
| 17 | ||
| 18 | sub needs_lines { 1 } | |
| 19 | sub perlio_ok { 0 } | |
| 20 | ||
| 21 | use utf8; | |
| 22 | our %UNI2GSM = ( | |
| 23 | "\x{0040}" => "\x00", # COMMERCIAL AT | |
| 24 | "\x{000A}" => "\x0A", # LINE FEED | |
| 25 | "\x{000C}" => "\x1B\x0A", # FORM FEED | |
| 26 | "\x{000D}" => "\x0D", # CARRIAGE RETURN | |
| 27 | "\x{0020}" => "\x20", # SPACE | |
| 28 | "\x{0021}" => "\x21", # EXCLAMATION MARK | |
| 29 | "\x{0022}" => "\x22", # QUOTATION MARK | |
| 30 | "\x{0023}" => "\x23", # NUMBER SIGN | |
| 31 | "\x{0024}" => "\x02", # DOLLAR SIGN | |
| 32 | "\x{0025}" => "\x25", # PERCENT SIGN | |
| 33 | "\x{0026}" => "\x26", # AMPERSAND | |
| 34 | "\x{0027}" => "\x27", # APOSTROPHE | |
| 35 | "\x{0028}" => "\x28", # LEFT PARENTHESIS | |
| 36 | "\x{0029}" => "\x29", # RIGHT PARENTHESIS | |
| 37 | "\x{002A}" => "\x2A", # ASTERISK | |
| 38 | "\x{002B}" => "\x2B", # PLUS SIGN | |
| 39 | "\x{002C}" => "\x2C", # COMMA | |
| 40 | "\x{002D}" => "\x2D", # HYPHEN-MINUS | |
| 41 | "\x{002E}" => "\x2E", # FULL STOP | |
| 42 | "\x{002F}" => "\x2F", # SOLIDUS | |
| 43 | "\x{0030}" => "\x30", # DIGIT ZERO | |
| 44 | "\x{0031}" => "\x31", # DIGIT ONE | |
| 45 | "\x{0032}" => "\x32", # DIGIT TWO | |
| 46 | "\x{0033}" => "\x33", # DIGIT THREE | |
| 47 | "\x{0034}" => "\x34", # DIGIT FOUR | |
| 48 | "\x{0035}" => "\x35", # DIGIT FIVE | |
| 49 | "\x{0036}" => "\x36", # DIGIT SIX | |
| 50 | "\x{0037}" => "\x37", # DIGIT SEVEN | |
| 51 | "\x{0038}" => "\x38", # DIGIT EIGHT | |
| 52 | "\x{0039}" => "\x39", # DIGIT NINE | |
| 53 | "\x{003A}" => "\x3A", # COLON | |
| 54 | "\x{003B}" => "\x3B", # SEMICOLON | |
| 55 | "\x{003C}" => "\x3C", # LESS-THAN SIGN | |
| 56 | "\x{003D}" => "\x3D", # EQUALS SIGN | |
| 57 | "\x{003E}" => "\x3E", # GREATER-THAN SIGN | |
| 58 | "\x{003F}" => "\x3F", # QUESTION MARK | |
| 59 | "\x{0041}" => "\x41", # LATIN CAPITAL LETTER A | |
| 60 | "\x{0042}" => "\x42", # LATIN CAPITAL LETTER B | |
| 61 | "\x{0043}" => "\x43", # LATIN CAPITAL LETTER C | |
| 62 | "\x{0044}" => "\x44", # LATIN CAPITAL LETTER D | |
| 63 | "\x{0045}" => "\x45", # LATIN CAPITAL LETTER E | |
| 64 | "\x{0046}" => "\x46", # LATIN CAPITAL LETTER F | |
| 65 | "\x{0047}" => "\x47", # LATIN CAPITAL LETTER G | |
| 66 | "\x{0048}" => "\x48", # LATIN CAPITAL LETTER H | |
| 67 | "\x{0049}" => "\x49", # LATIN CAPITAL LETTER I | |
| 68 | "\x{004A}" => "\x4A", # LATIN CAPITAL LETTER J | |
| 69 | "\x{004B}" => "\x4B", # LATIN CAPITAL LETTER K | |
| 70 | "\x{004C}" => "\x4C", # LATIN CAPITAL LETTER L | |
| 71 | "\x{004D}" => "\x4D", # LATIN CAPITAL LETTER M | |
| 72 | "\x{004E}" => "\x4E", # LATIN CAPITAL LETTER N | |
| 73 | "\x{004F}" => "\x4F", # LATIN CAPITAL LETTER O | |
| 74 | "\x{0050}" => "\x50", # LATIN CAPITAL LETTER P | |
| 75 | "\x{0051}" => "\x51", # LATIN CAPITAL LETTER Q | |
| 76 | "\x{0052}" => "\x52", # LATIN CAPITAL LETTER R | |
| 77 | "\x{0053}" => "\x53", # LATIN CAPITAL LETTER S | |
| 78 | "\x{0054}" => "\x54", # LATIN CAPITAL LETTER T | |
| 79 | "\x{0055}" => "\x55", # LATIN CAPITAL LETTER U | |
| 80 | "\x{0056}" => "\x56", # LATIN CAPITAL LETTER V | |
| 81 | "\x{0057}" => "\x57", # LATIN CAPITAL LETTER W | |
| 82 | "\x{0058}" => "\x58", # LATIN CAPITAL LETTER X | |
| 83 | "\x{0059}" => "\x59", # LATIN CAPITAL LETTER Y | |
| 84 | "\x{005A}" => "\x5A", # LATIN CAPITAL LETTER Z | |
| 85 | "\x{005F}" => "\x11", # LOW LINE | |
| 86 | "\x{0061}" => "\x61", # LATIN SMALL LETTER A | |
| 87 | "\x{0062}" => "\x62", # LATIN SMALL LETTER B | |
| 88 | "\x{0063}" => "\x63", # LATIN SMALL LETTER C | |
| 89 | "\x{0064}" => "\x64", # LATIN SMALL LETTER D | |
| 90 | "\x{0065}" => "\x65", # LATIN SMALL LETTER E | |
| 91 | "\x{0066}" => "\x66", # LATIN SMALL LETTER F | |
| 92 | "\x{0067}" => "\x67", # LATIN SMALL LETTER G | |
| 93 | "\x{0068}" => "\x68", # LATIN SMALL LETTER H | |
| 94 | "\x{0069}" => "\x69", # LATIN SMALL LETTER I | |
| 95 | "\x{006A}" => "\x6A", # LATIN SMALL LETTER J | |
| 96 | "\x{006B}" => "\x6B", # LATIN SMALL LETTER K | |
| 97 | "\x{006C}" => "\x6C", # LATIN SMALL LETTER L | |
| 98 | "\x{006D}" => "\x6D", # LATIN SMALL LETTER M | |
| 99 | "\x{006E}" => "\x6E", # LATIN SMALL LETTER N | |
| 100 | "\x{006F}" => "\x6F", # LATIN SMALL LETTER O | |
| 101 | "\x{0070}" => "\x70", # LATIN SMALL LETTER P | |
| 102 | "\x{0071}" => "\x71", # LATIN SMALL LETTER Q | |
| 103 | "\x{0072}" => "\x72", # LATIN SMALL LETTER R | |
| 104 | "\x{0073}" => "\x73", # LATIN SMALL LETTER S | |
| 105 | "\x{0074}" => "\x74", # LATIN SMALL LETTER T | |
| 106 | "\x{0075}" => "\x75", # LATIN SMALL LETTER U | |
| 107 | "\x{0076}" => "\x76", # LATIN SMALL LETTER V | |
| 108 | "\x{0077}" => "\x77", # LATIN SMALL LETTER W | |
| 109 | "\x{0078}" => "\x78", # LATIN SMALL LETTER X | |
| 110 | "\x{0079}" => "\x79", # LATIN SMALL LETTER Y | |
| 111 | "\x{007A}" => "\x7A", # LATIN SMALL LETTER Z | |
| 112 | "\x{000C}" => "\x1B\x0A", # FORM FEED | |
| 113 | "\x{005B}" => "\x1B\x3C", # LEFT SQUARE BRACKET | |
| 114 | "\x{005C}" => "\x1B\x2F", # REVERSE SOLIDUS | |
| 115 | "\x{005D}" => "\x1B\x3E", # RIGHT SQUARE BRACKET | |
| 116 | "\x{005E}" => "\x1B\x14", # CIRCUMFLEX ACCENT | |
| 117 | "\x{007B}" => "\x1B\x28", # LEFT CURLY BRACKET | |
| 118 | "\x{007C}" => "\x1B\x40", # VERTICAL LINE | |
| 119 | "\x{007D}" => "\x1B\x29", # RIGHT CURLY BRACKET | |
| 120 | "\x{007E}" => "\x1B\x3D", # TILDE | |
| 121 | "\x{00A0}" => "\x1B", # NO-BREAK SPACE | |
| 122 | "\x{00A1}" => "\x40", # INVERTED EXCLAMATION MARK | |
| 123 | "\x{00A3}" => "\x01", # POUND SIGN | |
| 124 | "\x{00A4}" => "\x24", # CURRENCY SIGN | |
| 125 | "\x{00A5}" => "\x03", # YEN SIGN | |
| 126 | "\x{00A7}" => "\x5F", # SECTION SIGN | |
| 127 | "\x{00BF}" => "\x60", # INVERTED QUESTION MARK | |
| 128 | "\x{00C4}" => "\x5B", # LATIN CAPITAL LETTER A WITH DIAERESIS | |
| 129 | "\x{00C5}" => "\x0E", # LATIN CAPITAL LETTER A WITH RING ABOVE | |
| 130 | "\x{00C6}" => "\x1C", # LATIN CAPITAL LETTER AE | |
| 131 | "\x{00C9}" => "\x1F", # LATIN CAPITAL LETTER E WITH ACUTE | |
| 132 | "\x{00D1}" => "\x5D", # LATIN CAPITAL LETTER N WITH TILDE | |
| 133 | "\x{00D6}" => "\x5C", # LATIN CAPITAL LETTER O WITH DIAERESIS | |
| 134 | "\x{00D8}" => "\x0B", # LATIN CAPITAL LETTER O WITH STROKE | |
| 135 | "\x{00DC}" => "\x5E", # LATIN CAPITAL LETTER U WITH DIAERESIS | |
| 136 | "\x{00DF}" => "\x1E", # LATIN SMALL LETTER SHARP S | |
| 137 | "\x{00E0}" => "\x7F", # LATIN SMALL LETTER A WITH GRAVE | |
| 138 | "\x{00E4}" => "\x7B", # LATIN SMALL LETTER A WITH DIAERESIS | |
| 139 | "\x{00E5}" => "\x0F", # LATIN SMALL LETTER A WITH RING ABOVE | |
| 140 | "\x{00E6}" => "\x1D", # LATIN SMALL LETTER AE | |
| 141 | "\x{00E7}" => "\x09", # LATIN SMALL LETTER C WITH CEDILLA | |
| 142 | "\x{00E8}" => "\x04", # LATIN SMALL LETTER E WITH GRAVE | |
| 143 | "\x{00E9}" => "\x05", # LATIN SMALL LETTER E WITH ACUTE | |
| 144 | "\x{00EC}" => "\x07", # LATIN SMALL LETTER I WITH GRAVE | |
| 145 | "\x{00F1}" => "\x7D", # LATIN SMALL LETTER N WITH TILDE | |
| 146 | "\x{00F2}" => "\x08", # LATIN SMALL LETTER O WITH GRAVE | |
| 147 | "\x{00F6}" => "\x7C", # LATIN SMALL LETTER O WITH DIAERESIS | |
| 148 | "\x{00F8}" => "\x0C", # LATIN SMALL LETTER O WITH STROKE | |
| 149 | "\x{00F9}" => "\x06", # LATIN SMALL LETTER U WITH GRAVE | |
| 150 | "\x{00FC}" => "\x7E", # LATIN SMALL LETTER U WITH DIAERESIS | |
| 151 | "\x{0393}" => "\x13", # GREEK CAPITAL LETTER GAMMA | |
| 152 | "\x{0394}" => "\x10", # GREEK CAPITAL LETTER DELTA | |
| 153 | "\x{0398}" => "\x19", # GREEK CAPITAL LETTER THETA | |
| 154 | "\x{039B}" => "\x14", # GREEK CAPITAL LETTER LAMDA | |
| 155 | "\x{039E}" => "\x1A", # GREEK CAPITAL LETTER XI | |
| 156 | "\x{03A0}" => "\x16", # GREEK CAPITAL LETTER PI | |
| 157 | "\x{03A3}" => "\x18", # GREEK CAPITAL LETTER SIGMA | |
| 158 | "\x{03A6}" => "\x12", # GREEK CAPITAL LETTER PHI | |
| 159 | "\x{03A8}" => "\x17", # GREEK CAPITAL LETTER PSI | |
| 160 | "\x{03A9}" => "\x15", # GREEK CAPITAL LETTER OMEGA | |
| 161 | "\x{20AC}" => "\x1B\x65", # EURO SIGN | |
| 162 | ); | |
| 163 | our %GSM2UNI = reverse %UNI2GSM; | |
| 164 | our $ESC = "\x1b"; | |
| 165 | our $ATMARK = "\x40"; | |
| 166 | our $FBCHAR = "\x3F"; | |
| 167 | our $NBSP = "\x{00A0}"; | |
| 168 | ||
| 169 | #define ERR_DECODE_NOMAP "%s \"\\x%02" UVXf "\" does not map to Unicode" | |
| 170 | ||
| 171 | sub decode ($$;$) { | |
| 172 | my ( $obj, $bytes, $chk ) = @_; | |
| 173 | my $str; | |
| 174 | while ( length $bytes ) { | |
| 175 | my $c = substr( $bytes, 0, 1, '' ); | |
| 176 | my $u; | |
| 177 | if ( $c eq "\x00" ) { | |
| 178 | my $c2 = substr( $bytes, 0, 1, '' ); | |
| 179 | $u = | |
| 180 | !length $c2 ? $ATMARK | |
| 181 | : $c2 eq "\x00" ? "\x{0000}" | |
| 182 | : exists $GSM2UNI{$c2} ? $ATMARK . $GSM2UNI{$c2} | |
| 183 | : $chk | |
| 184 | ? croak sprintf( "\\x%02X\\x%02X does not map to Unicode", | |
| 185 | ord($c), ord($c2) ) | |
| 186 | : $ATMARK . $FBCHAR; | |
| 187 | ||
| 188 | } | |
| 189 | elsif ( $c eq $ESC ) { | |
| 190 | my $c2 = substr( $bytes, 0, 1, '' ); | |
| 191 | $u = | |
| 192 | exists $GSM2UNI{ $c . $c2 } ? $GSM2UNI{ $c . $c2 } | |
| 193 | : exists $GSM2UNI{$c2} ? $NBSP . $GSM2UNI{$c2} | |
| 194 | : $chk | |
| 195 | ? croak sprintf( "\\x%02X\\x%02X does not map to Unicode", | |
| 196 | ord($c), ord($c2) ) | |
| 197 | : $NBSP . $FBCHAR; | |
| 198 | } | |
| 199 | else { | |
| 200 | $u = | |
| 0263186c NC |
201 | exists $GSM2UNI{$c} |
| 202 | ? $GSM2UNI{$c} | |
| 203 | : $chk ? ref $chk eq 'CODE' | |
| 204 | ? $chk->( ord $c ) | |
| 205 | : croak sprintf( "\\x%02X does not map to Unicode", ord($c) ) | |
| 44b3b9c7 SP |
206 | : $FBCHAR; |
| 207 | } | |
| 208 | $str .= $u; | |
| 209 | } | |
| 210 | $_[1] = $bytes if $chk; | |
| 211 | return $str; | |
| 212 | } | |
| 213 | ||
| 214 | #define ERR_ENCODE_NOMAP "\"\\x{%04" UVxf "}\" does not map to %s" | |
| 215 | ||
| 216 | sub encode($$;$) { | |
| 217 | my ( $obj, $str, $chk ) = @_; | |
| 218 | my $bytes; | |
| 219 | while ( length $str ) { | |
| 220 | my $u = substr( $str, 0, 1, '' ); | |
| 221 | my $c; | |
| 222 | $bytes .= | |
| 0263186c NC |
223 | exists $UNI2GSM{$u} |
| 224 | ? $UNI2GSM{$u} | |
| 225 | : $chk ? ref $chk eq 'CODE' | |
| 226 | ? $chk->( ord($u) ) | |
| 227 | : croak sprintf( "\\x{%04x} does not map to %s", | |
| 228 | ord($u), $obj->name ) | |
| 44b3b9c7 SP |
229 | : $FBCHAR; |
| 230 | } | |
| 231 | $_[1] = $str if $chk; | |
| 232 | return $bytes; | |
| 233 | } | |
| 234 | ||
| 235 | 1; | |
| 236 | __END__ | |
| 237 | ||
| 238 | =head1 NAME | |
| 239 | ||
| 240 | Encode::GSM0338 -- ESTI GSM 03.38 Encoding | |
| 241 | ||
| 242 | =head1 SYNOPSIS | |
| 243 | ||
| 244 | use Encode qw/encode decode/; | |
| 245 | $gsm0338 = encode("gsm0338", $utf8); # loads Encode::GSM0338 implicitly | |
| 246 | $utf8 = decode("gsm0338", $gsm0338); # ditto | |
| 247 | ||
| 248 | =head1 DESCRIPTION | |
| 249 | ||
| 250 | GSM0338 is for GSM handsets. Though it shares alphanumerals with ASCII, | |
| 251 | control character ranges and other parts are mapped very differently, | |
| 252 | mainly to store Greek characters. There are also escape sequences | |
| 253 | (starting with 0x1B) to cover e.g. the Euro sign. | |
| 254 | ||
| 255 | This was once handled by L<Encode::Bytes> but because of all those | |
| 256 | unusual specifications, Encode 2.20 has relocated the support to | |
| 257 | this module. | |
| 258 | ||
| 259 | =head1 NOTES | |
| 260 | ||
| 261 | Unlike most other encodings, the following aways croaks on error | |
| 262 | for any $chk that evaluates to true. | |
| 263 | ||
| 264 | $gsm0338 = encode("gsm0338", $utf8 $chk); | |
| 265 | $utf8 = decode("gsm0338", $gsm0338, $chk); | |
| 266 | ||
| 267 | So if you want to check the validity of the encoding, surround the | |
| 268 | expression with C<eval {}> block as follows; | |
| 269 | ||
| 270 | eval { | |
| 271 | $utf8 = decode("gsm0338", $gsm0338, $chk); | |
| 272 | }; | |
| 273 | if ($@){ | |
| 274 | # handle exception here | |
| 275 | } | |
| 276 | ||
| 277 | =head1 BUGS | |
| 278 | ||
| 279 | ESTI GSM 03.38 Encoding itself. | |
| 280 | ||
| 281 | Mapping \x00 to '@' causes too much pain everywhere. | |
| 282 | ||
| 283 | Its use of \x1b (escape) is also very questionable. | |
| 284 | ||
| 285 | Because of those two, the code paging approach used use in ucm-based | |
| 286 | Encoding SOMETIMES fails so this module was written. | |
| 287 | ||
| 288 | =head1 SEE ALSO | |
| 289 | ||
| 290 | L<Encode> | |
| 291 | ||
| 292 | =cut |