source: trunk/gsdl/perllib/unicode.pm@ 2018

Last change on this file since 2018 was 1870, checked in by sjboddie, 23 years ago

Tidied up language support stuff.
  • Property svn:executable set to *
  • Property svn:keywords set to Author Date Id Revision
File size: 11.0 KB
Line 
1###########################################################################
2#
3# unicode.pm --
4# A component of the Greenstone digital library software
5# from the New Zealand Digital Library Project at the
6# University of Waikato, New Zealand.
7#
8# Copyright (C) 1999 New Zealand Digital Library Project
9#
10# This program is free software; you can redistribute it and/or modify
11# it under the terms of the GNU General Public License as published by
12# the Free Software Foundation; either version 2 of the License, or
13# (at your option) any later version.
14#
15# This program is distributed in the hope that it will be useful,
16# but WITHOUT ANY WARRANTY; without even the implied warranty of
17# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18# GNU General Public License for more details.
19#
20# You should have received a copy of the GNU General Public License
21# along with this program; if not, write to the Free Software
22# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
23#
24###########################################################################
25
26# useful functions for dealing with Unicode
27
28# Unicode strings are stored as arrays of scalars as perl
29# lacks characters are 8-bit (currently)
30
31package unicode;
32use encodings;
33
34# ascii2unicode takes an (extended) ascii string (ISO-8859-1)
35# and returns a unicode array.
36sub ascii2unicode {
37 my ($in) = @_;
38 my $out = [];
39
40 my $i = 0;
41 my $len = length($in);
42 while ($i < $len) {
43 push (@$out, ord(substr ($in, $i, 1)));
44 $i++;
45 }
46
47 return $out;
48}
49
50# ascii2utf8 takes a reference to an (extended) ascii string and returns a
51# UTF-8 encoded string. This is just a faster version of
52# "&unicode2utf8(&ascii2unicode($str));"
53sub ascii2utf8 {
54 my ($in) = @_;
55 my $out = "";
56
57 my ($c);
58 my $i = 0;
59 my $len = length($$in);
60 while ($i < $len) {
61 $c = ord (substr ($$in, $i, 1));
62 if ($c < 0x80) {
63 # ascii character
64 $out .= chr ($c);
65
66 } else {
67 # extended ascii character
68 $out .= chr (0xc0 + (($c >> 6) & 0x1f));
69 $out .= chr (0x80 + ($c & 0x3f));
70 }
71 $i++;
72 }
73
74 return $out;
75}
76
77# unicode2utf8 takes a unicode array as input and encodes it
78# using utf-8
79sub unicode2utf8 {
80 my ($in) = @_;
81 my $out = "";
82
83 foreach $num (@$in) {
84 next unless defined $num;
85 if ($num < 0x80) {
86 $out .= chr ($num);
87
88 } elsif ($num < 0x800) {
89 $out .= chr (0xc0 + (($num >> 6) & 0x1f));
90 $out .= chr (0x80 + ($num & 0x3f));
91
92 } elsif ($num < 0xFFFF) {
93 $out .= chr (0xe0 + (($num >> 12) & 0xf));
94 $out .= chr (0x80 + (($num >> 6) & 0x3f));
95 $out .= chr (0x80 + ($num & 0x3f));
96
97 } else {
98 # error, don't encode anything
99 die;
100 }
101 }
102 return $out;
103}
104
105# utf82unicode takes a utf-8 string and produces a unicode
106# array
107sub utf82unicode {
108 my ($in) = @_;
109 my $out = [];
110
111 my $i = 0;
112 my ($c1, $c2, $c3);
113 $len = length($in);
114 while ($i < $len) {
115 if (($c1 = ord(substr ($in, $i, 1))) < 0x80) {
116 # normal ascii character
117 push (@$out, $c1);
118
119 } elsif ($c1 < 0xc0) {
120 # error, was expecting the first byte of an
121 # encoded character. Do nothing.
122
123 } elsif ($c1 < 0xe0 && $i+1 < $len) {
124 # an encoded character with two bytes
125 $c2 = ord (substr ($in, $i+1, 1));
126 if ($c2 >= 0x80 && $c2 < 0xc0) {
127 # everything looks ok
128 push (@$out, ((($c1 & 0x1f) << 6) +
129 ($c2 & 0x3f)));
130 $i++; # gobbled an extra byte
131 }
132
133 } elsif ($c1 < 0xf0 && $i+2 < $len) {
134 # an encoded character with three bytes
135 $c2 = ord (substr ($in, $i+1, 1));
136 $c3 = ord (substr ($in, $i+2, 1));
137 if ($c2 >= 0x80 && $c2 < 0xc0 &&
138 $c3 >= 0x80 && $c3 < 0xc0) {
139 # everything looks ok
140 push (@$out, ((($c1 & 0xf) << 12) +
141 (($c2 & 0x3f) << 6) +
142 ($c3 & 0x3f)));
143
144 $i += 2; # gobbled an extra two bytes
145 }
146
147 } else {
148 # error, only decode Unicode characters not full UCS.
149 # Do nothing.
150 }
151
152 $i++;
153 }
154
155 return $out;
156}
157
158# unicode2ucs2 takes a unicode array and produces a UCS-2
159# unicode string (every two bytes forms a unicode character)
160sub unicode2ucs2 {
161 my ($in) = @_;
162 my $out = "";
163
164 foreach $num (@$in) {
165 $out .= chr (($num & 0xff00) >> 8);
166 $out .= chr ($num & 0xff);
167 }
168
169 return $out;
170}
171
172# ucs22unicode takes a UCS-2 string and produces a unicode array
173sub ucs22unicode {
174 my ($in) = @_;
175 my $out = [];
176
177 my $i = 0;
178 my $len = length ($in);
179 while ($i+1 < $len) {
180 push (@$out, ord (substr($in, $i, 1)) << 8 +
181 ord (substr($in, $i+1, 1)));
182
183 $i ++;
184 }
185
186 return $out;
187}
188
189# takes a reference to a string and returns a reference to a unicode array
190sub convert2unicode {
191 my ($encoding, $textref) = @_;
192
193 if (!defined $encodings::encodings->{$encoding}) {
194 print STDERR "unicode::convert2unicode: ERROR: Unsupported encoding ($encoding)\n";
195 return [];
196 }
197
198 my $encodename = "$encoding-unicode";
199 my $enc_info = $encodings::encodings->{$encoding};
200 my $mapfile = &util::filename_cat($ENV{'GSDLHOME'}, "mappings",
201 "to_uc", $enc_info->{'mapfile'});
202 if (!&loadmapencoding ($encodename, $mapfile)) {
203 print STDERR "unicode: ERROR - could not load encoding $encodename\n";
204 return [];
205 }
206
207 if (defined $enc_info->{'converter'}) {
208 my $converter = $enc_info->{'converter'};
209 return &$converter ($encodename, $textref);
210 }
211
212 if ($translations{$encodename}->{'count'} == 1) {
213 return &singlebyte2unicode ($encodename, $textref);
214 } else {
215 return &doublebyte2unicode ($encodename, $textref);
216 }
217}
218
219# singlebyte2unicode converts simple 8 bit encodings where characters below
220# 0x80 are normal ascii characters and the rest are decoded using the
221# appropriate mapping files.
222#
223# Examples of encodings that may be converted using singlebyte2unicode are
224# the iso-8859 and windows-125* series).
225sub singlebyte2unicode {
226 my ($encodename, $textref) = @_;
227
228 my @outtext = ();
229 my $len = length($$textref);
230 my ($c);
231 my $i = 0;
232
233 while ($i < $len) {
234 if (($c = ord(substr($$textref, $i, 1))) < 0x80) {
235 # normal ascii character
236 push (@outtext, $c);
237 } else {
238 $c = &transchar ($encodename, $c);
239 # put a black square if cannot translate
240 $c = 0x25A1 if $c == 0;
241 push (@outtext, $c);
242 }
243 $i ++;
244 }
245 return \@outtext;
246}
247
248# doublebyte2unicode converts simple two byte encodings where characters
249# below code point 0x80 are single-byte characters and the rest are
250# double-byte characters.
251#
252# Examples of encodings that may be converted using doublebyte2unicode are
253# CJK encodings like GB encoded Chinese and UHC Korean.
254#
255# Note that no error checking is performed to make sure that the input text
256# is valid for the given encoding.
257#
258# Also, encodings that may contain characters of more than two bytes are
259# not supported (any EUC encoded text may in theory contain 3-byte
260# characters but in practice only one and two byte characters are used).
261sub doublebyte2unicode {
262 my ($encodename, $textref) = @_;
263
264 my @outtext = ();
265 my $len = length($$textref);
266 my ($c1, $c2);
267 my $i = 0;
268
269 while ($i < $len) {
270 if (($c1 = ord(substr($$textref, $i, 1))) >= 0x80) {
271 if ($i+1 < $len) {
272 # double-byte character
273 $c2 = ord(substr($$textref, $i+1, 1));
274 my $c = &transchar ($encodename, ($c1 << 8) | $c2);
275 # put a black square if cannot translate
276 $c = 0x25A1 if $c == 0;
277 push (@outtext, $c);
278 $i += 2;
279
280 } else {
281 # error
282 print STDERR "unicode: ERROR missing second half of double-byte character\n";
283 $i++;
284 }
285
286 } else {
287 # single-byte character
288 push (@outtext, $c1);
289 $i++;
290 }
291 }
292 return \@outtext;
293}
294
295# Shift-JIS to unicode
296# We can't use doublebyte2unicode for Shift-JIS because it uses some
297# single-byte characters above code point 0x80 (i.e. half-width katakana
298# characters in the range 0xA1-0xDF)
299sub shiftjis2unicode {
300 my ($encodename, $textref) = @_;
301
302 my @outtext = ();
303 my $len = length($$textref);
304 my ($c1, $c2);
305 my $i = 0;
306
307 while ($i < $len) {
308 $c1 = ord(substr($$textref, $i, 1));
309
310 if (($c1 >= 0xA1 && $c1 <= 0xDF) || $c1 == 0x5c || $c1 == 0x7E) {
311 # Single-byte half-width katakana character or
312 # JIS Roman yen or overline characters
313 my $c = &transchar ($encodename, $c1);
314 # - put a black square if cannot translate
315 $c = 0x25A1 if $c == 0;
316 push (@outtext, $c);
317 $i++;
318
319 } elsif ($c1 < 0x80) {
320 # ASCII
321 push (@outtext, $c1);
322 $i ++;
323
324 } elsif ($c1 < 0xEF) {
325 if ($i+1 < $len) {
326 $c2 = ord(substr($$textref, $i+1, 1));
327 if (($c2 >= 0x40 && $c2 <= 0x7E) || ($c2 >= 0x80 && $c2 <= 0xFC)) {
328 # Double-byte shift-jis character
329 my $c = &transchar ($encodename, ($c1 << 8) | $c2);
330 # put a black square if cannot translate
331 $c = 0x25A1 if $c == 0;
332 push (@outtext, $c);
333 } else {
334 # error
335 print STDERR "unicode: ERROR Invalid Shift-JIS character\n";
336 }
337 $i += 2;
338 } else {
339 # error
340 print STDERR "unicode: ERROR missing second half of Shift-JIS character\n";
341 $i ++;
342 }
343 } else {
344 # error
345 print STDERR "unicode: ERROR Invalid Shift-JIS character\n";
346 $i ++;
347 }
348 }
349 return \@outtext;
350}
351
352sub transchar {
353 my ($encoding, $from) = @_;
354 my $high = ($from / 256) % 256;
355 my $low = $from % 256;
356
357 return 0 unless defined $translations{$encoding};
358
359 my $block = $translations{$encoding}->{'map'};
360
361 if (ref ($block->[$high]) ne "ARRAY") {
362 return 0;
363 }
364 return $block->[$high]->[$low];
365}
366
367# %translations is of the form:
368#
369# encodings{encodingname-encodingname}->{'map'}->blocktranslation
370# blocktranslation->[[0-255],[256-511], ..., [65280-65535]]
371#
372# Any of the top translation blocks can point to an undefined
373# value. This data structure aims to allow fast translation and
374# efficient storage.
375%translations = ();
376
377# @array256 is used for initialisation, there must be
378# a better way...
379@array256 = (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
380 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
381 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
382 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
383 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
384 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
385 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
386 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
387 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
388 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
389 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
390 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
391 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
392 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
393 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
394 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
395
396# returns 1 if successful, 0 if unsuccessful
397sub loadmapencoding {
398 my ($encoding, $mapfile) = @_;
399
400 # check to see if the encoding has already been loaded
401 return 1 if (defined $translations{$encoding});
402
403 return 0 unless open (MAPFILE, $mapfile);
404 binmode (MAPFILE);
405
406 $translations{$encoding} = {'map' => [@array256], 'count' => 0};
407 my $block = $translations{$encoding};
408
409 my ($in,$i,$j);
410 while (read(MAPFILE, $in, 1) == 1) {
411 $i = unpack ("C", $in);
412 $block->{'map'}->[$i] = [@array256];
413 for ($j=0; $j<256 && read(MAPFILE, $in, 2)==2; $j++) {
414 my ($n1, $n2) = unpack ("CC", $in);
415 $block->{'map'}->[$i]->[$j] = ($n1*256) + $n2;
416 }
417 $block->{'count'} ++;
418 }
419
420 close (MAPFILE);
421}
422
4231;
Note: See TracBrowser for help on using the repository browser.