Charset.pm 16 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423
  1. #------------------------------------------------------------------------------
  2. # File: Charset.pm
  3. #
  4. # Description: ExifTool character encoding routines
  5. #
  6. # Revisions: 2009/08/28 - P. Harvey created
  7. # 2010/01/20 - P. Harvey complete re-write
  8. # 2010/07/16 - P. Harvey added UTF-16 support
  9. #------------------------------------------------------------------------------
  10. package Image::ExifTool::Charset;
  11. use strict;
  12. use vars qw($VERSION %csType);
  13. use Image::ExifTool qw(:DataAccess :Utils);
  14. $VERSION = '1.09';
  15. my %charsetTable; # character set tables we've loaded
  16. # lookup for converting Unicode to 1-byte character sets
  17. my %unicode2byte = (
  18. Latin => { # pre-load Latin (cp1252) for speed
  19. 0x20ac => 0x80, 0x0160 => 0x8a, 0x2013 => 0x96,
  20. 0x201a => 0x82, 0x2039 => 0x8b, 0x2014 => 0x97,
  21. 0x0192 => 0x83, 0x0152 => 0x8c, 0x02dc => 0x98,
  22. 0x201e => 0x84, 0x017d => 0x8e, 0x2122 => 0x99,
  23. 0x2026 => 0x85, 0x2018 => 0x91, 0x0161 => 0x9a,
  24. 0x2020 => 0x86, 0x2019 => 0x92, 0x203a => 0x9b,
  25. 0x2021 => 0x87, 0x201c => 0x93, 0x0153 => 0x9c,
  26. 0x02c6 => 0x88, 0x201d => 0x94, 0x017e => 0x9e,
  27. 0x2030 => 0x89, 0x2022 => 0x95, 0x0178 => 0x9f,
  28. },
  29. );
  30. # bit flags for all supported character sets
  31. # (this number must be correct because it dictates the decoding algorithm!)
  32. # 0x001 = character set requires a translation module
  33. # 0x002 = inverse conversion not yet supported by Recompose()
  34. # 0x080 = some characters with codepoints in the range 0x00-0x7f are remapped
  35. # 0x100 = 1-byte fixed-width characters
  36. # 0x200 = 2-byte fixed-width characters
  37. # 0x400 = 4-byte fixed-width characters
  38. # 0x800 = 1- and 2-byte variable-width characters, or 1-byte
  39. # fixed-width characters that map into multiple codepoints
  40. # Note: In its public interface, ExifTool can currently only support type 0x101
  41. # and lower character sets because strings are only converted if they
  42. # contain characters above 0x7f and there is no provision for specifying
  43. # the byte order for input/output values
  44. %csType = (
  45. UTF8 => 0x100,
  46. ASCII => 0x100, # (treated like UTF8)
  47. Arabic => 0x101,
  48. Baltic => 0x101,
  49. Cyrillic => 0x101,
  50. Greek => 0x101,
  51. Hebrew => 0x101,
  52. Latin => 0x101,
  53. Latin2 => 0x101,
  54. MacCroatian => 0x101,
  55. MacCyrillic => 0x101,
  56. MacGreek => 0x101,
  57. MacIceland => 0x101,
  58. MacLatin2 => 0x101,
  59. MacRoman => 0x101,
  60. MacRomanian => 0x101,
  61. MacTurkish => 0x101,
  62. Thai => 0x101,
  63. Turkish => 0x101,
  64. Vietnam => 0x101,
  65. MacArabic => 0x103, # (directional characters not supported)
  66. PDFDoc => 0x181,
  67. Unicode => 0x200, # (UCS2)
  68. UCS2 => 0x200,
  69. UTF16 => 0x200,
  70. Symbol => 0x201,
  71. JIS => 0x201,
  72. UCS4 => 0x400,
  73. MacChineseCN => 0x803,
  74. MacChineseTW => 0x803,
  75. MacHebrew => 0x803, # (directional characters not supported)
  76. MacKorean => 0x803,
  77. MacRSymbol => 0x803,
  78. MacThai => 0x803,
  79. MacJapanese => 0x883,
  80. ShiftJIS => 0x883,
  81. );
  82. #------------------------------------------------------------------------------
  83. # Load character set module
  84. # Inputs: 0) Module name
  85. # Returns: Reference to lookup hash, or undef on error
  86. sub LoadCharset($)
  87. {
  88. my $charset = shift;
  89. my $conv = $charsetTable{$charset};
  90. unless ($conv) {
  91. # load translation module
  92. my $module = "Image::ExifTool::Charset::$charset";
  93. no strict 'refs';
  94. if (%$module or eval "require $module") {
  95. $conv = $charsetTable{$charset} = \%$module;
  96. }
  97. }
  98. return $conv;
  99. }
  100. #------------------------------------------------------------------------------
  101. # Does an array contain valid UTF-16 characters?
  102. # Inputs: 0) array reference to list of UCS-2 values
  103. # Returns: 0=invalid UTF-16, 1=valid UTF-16 with no surrogates, 2=valid UTF-16 with surrogates
  104. sub IsUTF16($)
  105. {
  106. local $_;
  107. my $uni = shift;
  108. my $surrogate;
  109. foreach (@$uni) {
  110. my $hiBits = ($_ & 0xfc00);
  111. if ($hiBits == 0xfc00) {
  112. # check for invalid values in UTF-16
  113. return 0 if $_ == 0xffff or $_ == 0xfffe or ($_ >= 0xfdd0 and $_ <= 0xfdef);
  114. } elsif ($surrogate) {
  115. return 0 if $hiBits != 0xdc00;
  116. $surrogate = 0;
  117. } else {
  118. return 0 if $hiBits == 0xdc00;
  119. $surrogate = 1 if $hiBits == 0xd800;
  120. }
  121. }
  122. return 1 if not defined $surrogate;
  123. return 2 unless $surrogate;
  124. return 0;
  125. }
  126. #------------------------------------------------------------------------------
  127. # Decompose string with specified encoding into an array of integer code points
  128. # Inputs: 0) ExifTool object ref (or undef), 1) string, 2) character set name,
  129. # 3) optional byte order ('II','MM','Unknown' or undef to use ExifTool ordering)
  130. # Returns: Reference to array of Unicode values
  131. # Notes: Accepts any type of character set
  132. # - byte order only used for fixed-width 2-byte and 4-byte character sets
  133. # - byte order mark observed and then removed with UCS2 and UCS4
  134. # - no warnings are issued if ExifTool object is not provided
  135. sub Decompose($$$;$)
  136. {
  137. local $_;
  138. my ($et, $val, $charset) = @_; # ($byteOrder assigned later if required)
  139. my $type = $csType{$charset};
  140. my (@uni, $conv);
  141. if ($type & 0x001) {
  142. $conv = LoadCharset($charset);
  143. unless ($conv) {
  144. # (shouldn't happen)
  145. $et->Warn("Invalid character set $charset") if $et;
  146. return \@uni; # error!
  147. }
  148. } elsif ($type == 0x100) {
  149. # convert ASCII and UTF8 (treat ASCII as UTF8)
  150. if ($] < 5.006001) {
  151. # do it ourself
  152. @uni = Image::ExifTool::UnpackUTF8($val);
  153. } else {
  154. # handle warnings from malformed UTF-8
  155. undef $Image::ExifTool::evalWarning;
  156. local $SIG{'__WARN__'} = \&Image::ExifTool::SetWarning;
  157. # (somehow the meaning of "U0" was reversed in Perl 5.10.0!)
  158. @uni = unpack($] < 5.010000 ? 'U0U*' : 'C0U*', $val);
  159. # issue warning if we had errors
  160. if ($Image::ExifTool::evalWarning and $et and not $$et{WarnBadUTF8}) {
  161. $et->Warn('Malformed UTF-8 character(s)');
  162. $$et{WarnBadUTF8} = 1;
  163. }
  164. }
  165. return \@uni; # all done!
  166. }
  167. if ($type & 0x100) { # 1-byte fixed-width characters
  168. @uni = unpack('C*', $val);
  169. foreach (@uni) {
  170. $_ = $$conv{$_} if defined $$conv{$_};
  171. }
  172. } elsif ($type & 0x600) { # 2-byte or 4-byte fixed-width characters
  173. my $unknown;
  174. my $byteOrder = $_[3];
  175. if (not $byteOrder) {
  176. $byteOrder = GetByteOrder();
  177. } elsif ($byteOrder eq 'Unknown') {
  178. $byteOrder = GetByteOrder();
  179. $unknown = 1;
  180. }
  181. my $fmt = $byteOrder eq 'MM' ? 'n*' : 'v*';
  182. if ($type & 0x400) { # 4-byte
  183. $fmt = uc $fmt; # unpack as 'N*' or 'V*'
  184. # honour BOM if it exists
  185. $val =~ s/^(\0\0\xfe\xff|\xff\xfe\0\0)// and $fmt = $1 eq "\0\0\xfe\xff" ? 'N*' : 'V*';
  186. undef $unknown; # (byte order logic applies to 2-byte only)
  187. } elsif ($val =~ s/^(\xfe\xff|\xff\xfe)//) {
  188. $fmt = $1 eq "\xfe\xff" ? 'n*' : 'v*';
  189. undef $unknown;
  190. }
  191. # convert from UCS2 or UCS4
  192. @uni = unpack($fmt, $val);
  193. if (not $conv) {
  194. # no translation necessary
  195. if ($unknown) {
  196. # check the byte order
  197. my (%bh, %bl);
  198. my ($zh, $zl) = (0, 0);
  199. foreach (@uni) {
  200. $bh{$_ >> 8} = 1;
  201. $bl{$_ & 0xff} = 1;
  202. ++$zh unless $_ & 0xff00;
  203. ++$zl unless $_ & 0x00ff;
  204. }
  205. # count the number of unique values in the hi and lo bytes
  206. my ($bh, $bl) = (scalar(keys %bh), scalar(keys %bl));
  207. # the byte with the greater number of unique values should be
  208. # the low-order byte, otherwise the byte which is zero more
  209. # often is likely the high-order byte
  210. if ($bh > $bl or ($bh == $bl and $zl > $zh)) {
  211. # we guessed wrong, so decode using the other byte order
  212. $fmt =~ tr/nvNV/vnVN/;
  213. @uni = unpack($fmt, $val);
  214. }
  215. }
  216. # handle surrogate pairs of UTF-16
  217. if ($charset eq 'UTF16') {
  218. my $i;
  219. for ($i=0; $i<$#uni; ++$i) {
  220. next unless ($uni[$i] & 0xfc00) == 0xd800 and
  221. ($uni[$i+1] & 0xfc00) == 0xdc00;
  222. my $cp = 0x10000 + (($uni[$i] & 0x3ff) << 10) + ($uni[$i+1] & 0x3ff);
  223. splice(@uni, $i, 2, $cp);
  224. }
  225. }
  226. } elsif ($unknown) {
  227. # count encoding errors as we do the translation
  228. my $e1 = 0;
  229. foreach (@uni) {
  230. defined $$conv{$_} and $_ = $$conv{$_}, next;
  231. ++$e1;
  232. }
  233. # try the other byte order if we had any errors
  234. if ($e1) {
  235. $fmt = $byteOrder eq 'MM' ? 'v*' : 'n*'; #(reversed)
  236. my @try = unpack($fmt, $val);
  237. my $e2 = 0;
  238. foreach (@try) {
  239. defined $$conv{$_} and $_ = $$conv{$_}, next;
  240. ++$e2;
  241. }
  242. # use this byte order if there are fewer errors
  243. return \@try if $e2 < $e1;
  244. }
  245. } else {
  246. # translate any characters found in the lookup
  247. foreach (@uni) {
  248. $_ = $$conv{$_} if defined $$conv{$_};
  249. }
  250. }
  251. } else { # variable-width characters
  252. # unpack into bytes
  253. my @bytes = unpack('C*', $val);
  254. while (@bytes) {
  255. my $ch = shift @bytes;
  256. my $cv = $$conv{$ch};
  257. # pass straight through if no translation
  258. $cv or push(@uni, $ch), next;
  259. # byte translates into single Unicode character
  260. ref $cv or push(@uni, $cv), next;
  261. # byte maps into multiple Unicode characters
  262. ref $cv eq 'ARRAY' and push(@uni, @$cv), next;
  263. # handle 2-byte character codes
  264. $ch = shift @bytes;
  265. if (defined $ch) {
  266. if ($$cv{$ch}) {
  267. $cv = $$cv{$ch};
  268. ref $cv or push(@uni, $cv), next;
  269. push @uni, @$cv; # multiple Unicode characters
  270. } else {
  271. push @uni, ord('?'); # encoding error
  272. unshift @bytes, $ch;
  273. }
  274. } else {
  275. push @uni, ord('?'); # encoding error
  276. }
  277. }
  278. }
  279. return \@uni;
  280. }
  281. #------------------------------------------------------------------------------
  282. # Convert array of code point integers into a string with specified encoding
  283. # Inputs: 0) ExifTool ref (or undef), 1) unicode character array ref,
  284. # 2) character set (note: not all types are supported)
  285. # 3) byte order ('MM' or 'II', multi-byte sets only, defaults to current byte order)
  286. # Returns: converted string (truncated at null character if it exists), empty on error
  287. # Notes: converts elements of input character array to new code points
  288. # - ExifTool ref may be undef provided $charset is defined
  289. sub Recompose($$;$$)
  290. {
  291. local $_;
  292. my ($et, $uni, $charset) = @_; # ($byteOrder assigned later if required)
  293. my ($outVal, $conv, $inv);
  294. $charset or $charset = $$et{OPTIONS}{Charset};
  295. my $csType = $csType{$charset};
  296. if ($csType == 0x100) { # UTF8 (also treat ASCII as UTF8)
  297. if ($] >= 5.006001) {
  298. # let Perl do it
  299. $outVal = pack('C0U*', @$uni);
  300. } else {
  301. # do it ourself
  302. $outVal = Image::ExifTool::PackUTF8(@$uni);
  303. }
  304. $outVal =~ s/\0.*//s; # truncate at null terminator
  305. return $outVal;
  306. }
  307. # get references to forward and inverse lookup tables
  308. if ($csType & 0x801) {
  309. $conv = LoadCharset($charset);
  310. unless ($conv) {
  311. $et->Warn("Missing charset $charset") if $et;
  312. return '';
  313. }
  314. $inv = $unicode2byte{$charset};
  315. # generate inverse lookup if necessary
  316. unless ($inv) {
  317. if (not $csType or $csType & 0x802) {
  318. $et->Warn("Invalid destination charset $charset") if $et;
  319. return '';
  320. }
  321. # prepare table to convert from Unicode to 1-byte characters
  322. my ($char, %inv);
  323. foreach $char (keys %$conv) {
  324. $inv{$$conv{$char}} = $char;
  325. }
  326. $inv = $unicode2byte{$charset} = \%inv;
  327. }
  328. }
  329. if ($csType & 0x100) { # 1-byte fixed-width
  330. # convert to specified character set
  331. foreach (@$uni) {
  332. next if $_ < 0x80;
  333. $$inv{$_} and $_ = $$inv{$_}, next;
  334. # our tables omit 1-byte characters with the same values as Unicode,
  335. # so pass them straight through after making sure there isn't a
  336. # different character with this byte value
  337. next if $_ < 0x100 and not $$conv{$_};
  338. $_ = ord('?'); # set invalid characters to '?'
  339. if ($et and not $$et{EncodingError}) {
  340. $et->Warn("Some character(s) could not be encoded in $charset");
  341. $$et{EncodingError} = 1;
  342. }
  343. }
  344. # repack as an 8-bit string and truncate at null
  345. $outVal = pack('C*', @$uni);
  346. $outVal =~ s/\0.*//s;
  347. } else { # 2-byte and 4-byte fixed-width
  348. # convert if required
  349. if ($inv) {
  350. $$inv{$_} and $_ = $$inv{$_} foreach @$uni;
  351. }
  352. # generate surrogate pairs of UTF-16
  353. if ($charset eq 'UTF16') {
  354. my $i;
  355. for ($i=0; $i<@$uni; ++$i) {
  356. next unless $$uni[$i] >= 0x10000 and $$uni[$i] < 0x10ffff;
  357. my $t = $$uni[$i] - 0x10000;
  358. my $w1 = 0xd800 + (($t >> 10) & 0x3ff);
  359. my $w2 = 0xdc00 + ($t & 0x3ff);
  360. splice(@$uni, $i, 1, $w1, $w2);
  361. ++$i; # skip surrogate pair
  362. }
  363. }
  364. # pack as 2- or 4-byte integer in specified byte order
  365. my $byteOrder = $_[3] || GetByteOrder();
  366. my $fmt = $byteOrder eq 'MM' ? 'n*' : 'v*';
  367. $fmt = uc($fmt) if $csType & 0x400;
  368. $outVal = pack($fmt, @$uni);
  369. }
  370. return $outVal;
  371. }
  372. 1; # end
  373. __END__
  374. =head1 NAME
  375. Image::ExifTool::Charset - ExifTool character encoding routines
  376. =head1 SYNOPSIS
  377. This module is required by Image::ExifTool.
  378. =head1 DESCRIPTION
  379. This module contains routines used by ExifTool to translate special
  380. character sets. Currently, the following character sets are supported:
  381. UTF8, UTF16, UCS2, UCS4, Arabic, Baltic, Cyrillic, Greek, Hebrew, JIS,
  382. Latin, Latin2, MacArabic, MacChineseCN, MacChineseTW, MacCroatian,
  383. MacCyrillic, MacGreek, MacHebrew, MacIceland, MacJapanese, MacKorean,
  384. MacLatin2, MacRSymbol, MacRoman, MacRomanian, MacThai, MacTurkish,
  385. PDFDoc, RSymbol, ShiftJIS, Symbol, Thai, Turkish, Vietnam
  386. However, only some of these character sets are available to the user via
  387. ExifTool options -- the multi-byte character sets are used only internally
  388. when decoding certain types of information.
  389. =head1 AUTHOR
  390. Copyright 2003-2016, Phil Harvey (phil at owl.phy.queensu.ca)
  391. This library is free software; you can redistribute it and/or modify it
  392. under the same terms as Perl itself.
  393. =head1 SEE ALSO
  394. L<Image::ExifTool(3pm)|Image::ExifTool>
  395. =cut