TestLib.pm 16 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431
  1. #------------------------------------------------------------------------------
  2. # File: TestLib.pm
  3. #
  4. # Description: Utility routines for testing ExifTool modules
  5. #
  6. # Revisions: Feb. 19/04 - P. Harvey Created
  7. # Feb. 26/04 - P. Harvey Name temporary file ".failed" and erase
  8. # it if the test passes
  9. # Feb. 27/04 - P. Harvey Change print format and allow ExifTool
  10. # object to be passed instead of tags hash ref.
  11. # Oct. 30/04 - P. Harvey Split testCompare() into separate sub.
  12. # May 18/05 - P. Harvey Tolerate round-off errors in floats.
  13. # Feb. 02/08 - P. Harvey Allow different timezones in time values
  14. # Sep. 16/08 - P. Harvey Improve timezone testing
  15. # Jul. 14/10 - P. Harvey Added writeInfo()
  16. # Jan. 06/12 - P. Harvey Patched MirBSD leap second "feature"
  17. #------------------------------------------------------------------------------
  18. package t::TestLib;
  19. use strict;
  20. require 5.002;
  21. require Exporter;
  22. use Image::ExifTool qw(ImageInfo);
  23. use vars qw($VERSION @ISA @EXPORT);
  24. $VERSION = '1.21';
  25. @ISA = qw(Exporter);
  26. @EXPORT = qw(check writeCheck writeInfo testCompare binaryCompare testVerbose);
  27. my $noTimeLocal;
  28. sub nearEnough($$);
  29. sub nearTime($$$$);
  30. sub formatValue($);
  31. sub writeInfo($$;$$);
  32. #------------------------------------------------------------------------------
  33. # Compare 2 binary files
  34. # Inputs: 0) file name 1, 1) file name 2
  35. # Returns: 1 if files are identical
  36. sub binaryCompare($$)
  37. {
  38. my ($file1, $file2) = @_;
  39. my $success = 1;
  40. open(TESTFILE1, $file1) or return 0;
  41. unless (open(TESTFILE2, $file2)) {
  42. close(TESTFILE1);
  43. return 0;
  44. }
  45. binmode(TESTFILE1);
  46. binmode(TESTFILE2);
  47. my ($buf1, $buf2);
  48. while (read(TESTFILE1, $buf1, 65536)) {
  49. read(TESTFILE2, $buf2, 65536) or $success = 0, last;
  50. $buf1 eq $buf2 or $success = 0, last;
  51. }
  52. read(TESTFILE2, $buf2, 65536) and $success = 0;
  53. close(TESTFILE1);
  54. close(TESTFILE2);
  55. return $success
  56. }
  57. #------------------------------------------------------------------------------
  58. # Compare 2 files and return true and erase the 2nd file if they are the same
  59. # Inputs: 0) file1, 1) file2, 2) test number, 3) flag to not erase test file
  60. # Returns: true if files are the same
  61. sub testCompare($$$;$)
  62. {
  63. my ($stdfile, $testfile, $testnum, $keep) = @_;
  64. my $success = 0;
  65. my $linenum;
  66. my $oldSep = $/;
  67. $/ = "\x0a"; # set input line separator
  68. if (open(FILE1, $stdfile)) {
  69. if (open(FILE2, $testfile)) {
  70. $success = 1;
  71. my ($line1, $line2);
  72. my $linenum = 0;
  73. for (;;) {
  74. $line1 = <FILE1>;
  75. last unless defined $line1;
  76. ++$linenum;
  77. $line2 = <FILE2>;
  78. if (defined $line2) {
  79. next if $line1 eq $line2;
  80. next if nearEnough($line1, $line2);
  81. }
  82. $success = 0;
  83. last;
  84. }
  85. if ($success) {
  86. # make sure there is nothing left in file2
  87. $line2 = <FILE2>;
  88. if ($line2) {
  89. ++$linenum;
  90. $success = 0;
  91. }
  92. }
  93. unless ($success) {
  94. warn "\n Test $testnum differs beginning at line $linenum:\n";
  95. defined $line1 or $line1 = '(null)';
  96. defined $line2 or $line2 = '(null)';
  97. chomp($line1,$line2);
  98. warn qq{ Test gave: "$line2"\n};
  99. warn qq{ Should be: "$line1"\n};
  100. }
  101. close(FILE2);
  102. }
  103. close(FILE1);
  104. }
  105. $/ = $oldSep; # restore input line separator
  106. # erase .failed file if test was successful
  107. $success and not $keep and unlink $testfile;
  108. return $success
  109. }
  110. #------------------------------------------------------------------------------
  111. # Return true if two test lines are close enough
  112. # Inputs: 0) line1, 1) line2
  113. # Returns: true if lines are similar enough to pass test
  114. sub nearEnough($$)
  115. {
  116. my ($line1, $line2) = @_;
  117. # of course, the version number will change...
  118. return 1 if $line1 =~ /^(.*ExifTool.*)\b\d{1,2}\.\d{2}\b(.*)/s and
  119. ($line2 eq "$1$Image::ExifTool::VERSION$Image::ExifTool::RELEASE$2" or
  120. $line2 eq "$1$Image::ExifTool::VERSION$2");
  121. # allow different FileModifyDate, FileAccessDate, FileCreateDate/FileInodeChangeDate and FilePermissions
  122. return 1 if $line1 =~ /(File\s?(Modif.*Date|Access\s?Date|Inode\s?Change\s?Date|Permissions))/ and
  123. ($line2 =~ /$1/ or $line2 =~ /File\s?Creat.*Date/);
  124. # allow CurrentIPTCDigest to be zero if Digest::MD5 isn't installed
  125. return 1 if $line1 =~ /Current IPTC Digest/ and
  126. $line2 =~ /Current IPTC Digest: (0|#){32}/ and
  127. not eval 'require Digest::MD5';
  128. # analyze every token in the line, and allow rounding
  129. # or format differences in floating point numbers
  130. my @toks1 = split /\s+/, $line1;
  131. my @toks2 = split /\s+/, $line2;
  132. my $lenChanged = 0;
  133. my $i;
  134. for ($i=0; ; ++$i) {
  135. return 1 if $i >= @toks1 and $i >= @toks2; # all tokens were OK
  136. my $tok1 = $toks1[$i];
  137. my $tok2 = $toks2[$i];
  138. last unless defined $tok1 and defined $tok2;
  139. next if $tok1 eq $tok2;
  140. # can't compare any more if either line was truncated (ie. ends with '[...]' or '[snip]')
  141. if ($tok1 =~ /\[(\.{3}|snip)\]$/ or $tok2 =~ /\[(\.{3}|snip)\]$/) {
  142. return 1 if $tok1=~ /^[-+]?\d+\./ or $tok2=~/^[-+]?\d+\./; # check for float
  143. return $lenChanged
  144. }
  145. if ($tok1 =~ /^(\d{2}|\d{4}):\d{2}:\d{2}/ and $tok2 =~ /^(\d{2}|\d{4}):\d{2}:\d{2}/ and
  146. not eval { require Time::Local })
  147. {
  148. unless ($noTimeLocal) {
  149. warn "Ignored time difference(s) because Time::Local is not installed\n";
  150. $noTimeLocal = 1;
  151. }
  152. next; # ignore times if Time::Local not available
  153. # account for different timezones
  154. } elsif ($tok1 =~ /^(\d{2}:\d{2}:\d{2})(Z|[-+]\d{2}:\d{2})$/i) {
  155. my $time = $1; # remove timezone
  156. # timezone may be wrong if writing date/time value in a different timezone
  157. next if $tok2 =~ /^(\d{2}:\d{2}:\d{2})(Z|[-+]\d{2}:\d{2})$/i and $time eq $1;
  158. # date/time may be wrong to if converting GMT value to local time
  159. last unless $i and $toks1[$i-1] =~ /^\d{4}:\d{2}:\d{2}$/ and
  160. $toks2[$i-1] =~ /^\d{4}:\d{2}:\d{2}$/;
  161. $tok1 = $toks1[$i-1] . ' ' . $tok1; # add date to give date/time value
  162. $tok2 = $toks2[$i-1] . ' ' . $tok2;
  163. last unless nearTime($tok1, $tok2, $line1, $line2);
  164. # date may be different if timezone shifted into next day
  165. } elsif ($tok1 =~ /^\d{4}:\d{2}:\d{2}$/ and $tok2 =~ /^\d{4}:\d{2}:\d{2}$/ and
  166. defined $toks1[$i+1] and defined $toks2[$i+1] and
  167. $toks1[$i+1] =~ /^(\d{2}:\d{2}:\d{2})(Z|[-+]\d{2}:\d{2})$/i and
  168. $toks2[$i+1] =~ /^(\d{2}:\d{2}:\d{2})(Z|[-+]\d{2}:\d{2})$/i)
  169. {
  170. ++$i;
  171. $tok1 .= ' ' . $toks1[$i]; # add time to give date/time value
  172. $tok2 .= ' ' . $toks2[$i];
  173. last unless nearTime($tok1, $tok2, $line1, $line2);
  174. # handle floating point numbers filtered by ExifTool test 29
  175. } elsif ($tok1 =~ s/(\.#)#*(e[-+]\#+)?/$1/g or $tok2 =~ s/(\.#)#*(e[-+]\#+)?/$1/g) {
  176. $tok2 =~ s/(\.#)#*(e[-+]\#+)?/$1/g;
  177. last if $tok1 ne $tok2;
  178. } else {
  179. # check to see if both tokens are floating point numbers (with decimal points!)
  180. if ($tok1 =~ s/([^\d.]+)$//) { # remove trailing units
  181. my $a = $1;
  182. last unless $tok2 =~ s/\Q$a\E$//;
  183. }
  184. if ($tok1 =~ s/^(\d+:\d+:)//) { # remove leading HH:MM:
  185. my $a = $1;
  186. last unless $tok2 =~ s/^\Q$a//;
  187. }
  188. if ($tok1 =~ s/^'//) { # remove leading quote
  189. last unless $tok2 =~ s/^'//;
  190. }
  191. last unless Image::ExifTool::IsFloat($tok1) and
  192. Image::ExifTool::IsFloat($tok2) and
  193. $tok1 =~ /\./ and $tok2 =~ /\./;
  194. last if $tok1 == 0 or $tok2 == 0;
  195. # numbers are bad if not the same to 5 significant figures
  196. if (abs(($tok1-$tok2)/($tok1+$tok2)) > 1e-5) {
  197. # (but allow last digit to be different due to round-off errors)
  198. my ($int1, $int2);
  199. ($int1 = $tok1) =~ tr/0-9//dc;
  200. ($int2 = $tok2) =~ tr/0-9//dc;
  201. my $dlen = length($int1) - length($int2);
  202. if ($dlen > 0) {
  203. $int2 .= '0' x $dlen;
  204. } elsif ($dlen < 0) {
  205. $int1 .= '0' x (-$dlen);
  206. }
  207. last if abs($int1-$int2) > 1.00001;
  208. }
  209. }
  210. # set flag if length changed
  211. $lenChanged = 1 if length($tok1) ne length($tok2);
  212. }
  213. return 0;
  214. }
  215. #------------------------------------------------------------------------------
  216. # Check two time strings to see if they are the same
  217. # Inputs: 0) time1, 1) time2, 2) line1, 3) line2
  218. # Returns: true on success
  219. sub nearTime($$$$)
  220. {
  221. my ($tok1, $tok2, $line1, $line2) = @_;
  222. my $t1 = Image::ExifTool::GetUnixTime($tok1, 'local') or return 0;
  223. my $t2 = Image::ExifTool::GetUnixTime($tok2, 'local') or return 0;
  224. my $td = $t2 - $t1;
  225. if ($td) {
  226. # patch for the MirBSD leap-second unconformity
  227. # (120 leap seconds should cover us until _well_ into the future)
  228. return 0 unless $^O eq 'mirbsd' and $td < 0 and $td > -120;
  229. warn "\n Ignoring $td second error due to MirBSD leap-second \"feature\":\n";
  230. chomp($line1,$line2);
  231. warn qq{ Test gave: "$line2"\n};
  232. warn qq{ Should be: "$line1"\n};
  233. }
  234. return 1;
  235. }
  236. #------------------------------------------------------------------------------
  237. # Format value for printing
  238. # Inputs: 0) value
  239. # Returns: string for printing
  240. sub formatValue($)
  241. {
  242. local $_;
  243. my $val = shift;
  244. my ($str, @a);
  245. if (ref $val eq 'SCALAR') {
  246. if ($$val =~ /^Binary data/) {
  247. $str = "($$val)";
  248. } else {
  249. $str = '(Binary data ' . length($$val) . ' bytes)';
  250. }
  251. } elsif (ref $val eq 'ARRAY') {
  252. foreach (@$val) {
  253. push @a, formatValue($_);
  254. }
  255. $str = '[' . join(',', @a) . ']';
  256. } elsif (ref $val eq 'HASH') {
  257. my $key;
  258. foreach $key (sort keys %$val) {
  259. push @a, $key . '=' . formatValue($$val{$key});
  260. }
  261. $str = '{' . join(',', @a) . '}';
  262. } elsif (defined $val) {
  263. # make sure there are no linefeeds in output
  264. ($str = $val) =~ tr/\x0a\x0d/;/;
  265. # translate unknown characters
  266. # $str =~ tr/\x01-\x1f\x80-\xff/\./;
  267. $str =~ tr/\x01-\x1f\x7f/./;
  268. # remove NULL chars
  269. $str =~ s/\x00//g;
  270. } else {
  271. $str = '';
  272. }
  273. return $str;
  274. }
  275. #------------------------------------------------------------------------------
  276. # Compare extracted information against a standard output file
  277. # Inputs: 0) [optional] ExifTool object reference
  278. # 1) tag hash reference, 2) test name, 3) test number
  279. # 4) test number for comparison file (if different than this test)
  280. # 5) top group number to test (2 by default)
  281. # Returns: 1 if check passed
  282. sub check($$$;$$$)
  283. {
  284. my $exifTool = shift if ref $_[0] ne 'HASH';
  285. my ($info, $testname, $testnum, $stdnum, $topGroup) = @_;
  286. return 0 unless $info;
  287. $stdnum = $testnum unless defined $stdnum;
  288. my $testfile = "t/${testname}_$testnum.failed";
  289. my $stdfile = "t/${testname}_$stdnum.out";
  290. open(FILE, ">$testfile") or return 0;
  291. # use one type of linefeed so this test works across platforms
  292. my $oldSep = $\;
  293. $\ = "\x0a"; # set output line separator
  294. # get a list of found tags
  295. my @tags;
  296. if ($exifTool) {
  297. # sort tags by group to make it a bit prettier
  298. @tags = $exifTool->GetTagList($info, 'Group0');
  299. } else {
  300. @tags = sort keys %$info;
  301. }
  302. #
  303. # Write information to file (with filename "TESTNAME_#.failed")
  304. #
  305. foreach (@tags) {
  306. my $val = formatValue($$info{$_});
  307. # (no "\n" needed since we set the output line separator above)
  308. if ($exifTool) {
  309. my @groups = $exifTool->GetGroup($_);
  310. my $groups = join ', ', @groups[0..($topGroup||2)];
  311. my $tagID = $exifTool->GetTagID($_);
  312. my $desc = $exifTool->GetDescription($_);
  313. print FILE "[$groups] $tagID - $desc: $val";
  314. } else {
  315. print FILE "$_: $val";
  316. }
  317. }
  318. close(FILE);
  319. $\ = $oldSep; # restore output line separator
  320. #
  321. # Compare the output file to the output from the standard test (TESTNAME_#.out)
  322. #
  323. return testCompare($stdfile, $testfile, $testnum);
  324. }
  325. #------------------------------------------------------------------------------
  326. # Test writing feature by writing specified information to JPEG file
  327. # Inputs: 0) list reference to lists of SetNewValue arguments
  328. # 1) test name, 2) test number, 3) optional source file name,
  329. # 4) true to only check tags which were written (or list ref for tags to check)
  330. # 5) flag set if nothing is expected to change in the output file
  331. # Returns: 1 if check passed
  332. sub writeCheck($$$;$$$)
  333. {
  334. my ($writeInfo, $testname, $testnum, $srcfile, $onlyWritten, $same) = @_;
  335. $srcfile or $srcfile = "t/images/$testname.jpg";
  336. my ($ext) = ($srcfile =~ /\.(.+?)$/);
  337. my $testfile = "t/${testname}_${testnum}_failed.$ext";
  338. my $exifTool = new Image::ExifTool;
  339. my @tags;
  340. if (ref $onlyWritten eq 'ARRAY') {
  341. @tags = @$onlyWritten;
  342. undef $onlyWritten;
  343. }
  344. foreach (@$writeInfo) {
  345. $exifTool->SetNewValue(@$_);
  346. push @tags, $$_[0] if $onlyWritten;
  347. }
  348. unlink $testfile;
  349. my $ok = writeInfo($exifTool, $srcfile, $testfile, $same);
  350. my $info = $exifTool->ImageInfo($testfile,{Duplicates=>1,Unknown=>1},@tags);
  351. my $rtnVal = check($exifTool, $info, $testname, $testnum);
  352. return 0 unless $ok and $rtnVal;
  353. unlink $testfile;
  354. return 1;
  355. }
  356. #------------------------------------------------------------------------------
  357. # Call Image::ExifTool::WriteInfo with error checking
  358. # Inputs: 0) ExifTool ref, 1) src file, 2) dst file, 3) true if nothing should change
  359. # Return: true on success
  360. sub writeInfo($$;$$)
  361. {
  362. my ($exifTool, $src, $dst, $same) = @_;
  363. # erase temporary file created by WriteInfo() if no destination file is given
  364. # (may be left over from previous crashed tests)
  365. unlink "${src}_exiftool_tmp" if not defined $dst and not ref $src;
  366. my $result = $exifTool->WriteInfo($src, $dst);
  367. my $err = '';
  368. $err .= " Error: WriteInfo() returned $result\n" if $result != ($same ? 2 : 1);
  369. my $info = $exifTool->GetInfo('Warning', 'Error');
  370. foreach (sort keys %$info) {
  371. my $tag = Image::ExifTool::GetTagName($_);
  372. $err .= " $tag: $$info{$_}\n";
  373. }
  374. return 1 unless $err;
  375. warn "\n$err";
  376. return 0;
  377. }
  378. #------------------------------------------------------------------------------
  379. # Test verbose output
  380. # Inputs: 0) test name, 1) test number, 2) Input file, 3) verbose level
  381. # Returns: true if test passed
  382. sub testVerbose($$$$)
  383. {
  384. my ($testname, $testnum, $infile, $verbose) = @_;
  385. my $testfile = "t/${testname}_$testnum";
  386. # capture verbose output by redirecting STDOUT
  387. return 0 unless open(TMPFILE,">$testfile.tmp");
  388. ImageInfo($infile, { Verbose => $verbose, TextOut => \*TMPFILE });
  389. close(TMPFILE);
  390. # re-write output file to change newlines to be same as standard test file
  391. # (if I was a Perl guru, maybe I would know a better way to do this)
  392. open(TMPFILE,"$testfile.tmp");
  393. open(TESTFILE,">$testfile.failed");
  394. my $oldSep = $\;
  395. $\ = "\x0a"; # set output line separator
  396. while (<TMPFILE>) {
  397. chomp; # remove existing newline
  398. print TESTFILE $_; # re-write line using \x0a for newlines
  399. }
  400. $\ = $oldSep; # restore output line separator
  401. close(TESTFILE);
  402. unlink("$testfile.tmp");
  403. return testCompare("$testfile.out","$testfile.failed",$testnum);
  404. }
  405. 1; #end