File: gdtest.ml

package info (click to toggle)
gd4o 1.0~alpha5-9
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, sid
  • size: 1,212 kB
  • sloc: xml: 1,618; ml: 1,136; ansic: 781; makefile: 85
file content (581 lines) | stat: -rw-r--r-- 20,596 bytes parent folder | download | duplicates (3)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
(* $Header: /home/cvs/gd4o/gdtest.ml,v 1.7 2003/11/25 01:02:32 matt Exp $ *)
(*
 * GD4O: An OCaml interface to the Gd graphics library.
 * Based on Shawn Wagner's OCamlGD 0.7.0.
 * Copyright (C) 2002  Shawn Wagner
 * Copyright (C) 2003  Matthew C. Gushee
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library 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.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 *)

open Gd;;


let write_header ch title desc =
  output_string ch ("************************************" ^
                    "************************************\n\n");
  output_string ch (title ^ ":\n");
  output_string ch (desc ^ "\n\n");
  output_string ch ("------------------------------------" ^
                    "------------------------------------\n\n\n")

let write_footer ch msg =
  output_string ch ("\n\n" ^ msg ^ "\n");
  output_string ch ("====================================" ^
                    "====================================\n\n\n")

let ok n msg = "   " ^ string_of_int n ^ ": [--OK--]: " ^ msg ^ "\n"
let failed n msg = "   " ^ string_of_int n ^ ": [FAILED]: " ^ msg ^ "\n"

let skiplineRE = Str.regexp "^\\([ \t]*#.*\\|[ \t]*\\)$"

let deg2rad = ( *. ) (3.1415926535 /. 180.)

let tempdir =
  try
    Sys.getenv "TMP"
  with Not_found ->
    begin
      try
        Sys.getenv "TEMP"
      with Not_found ->
        if Sys.file_exists "/tmp" then "/tmp"
        else if Sys.file_exists "/var/tmp" then "/var/tmp"
        else Sys.getcwd ()
    end;;


let shapes_test msg_ch =
  write_header msg_ch "SHAPES"
    ( "Create an image displaying various interesting shapes.\n" ^
      "Save output as 'shapes_test.png'.");
  let msg = output_string msg_ch in
  let img =
    try
      let i = create 512 384 in
      msg (ok 1 "created image");
      i
    with _ -> failwith "Failed to create image." in
  let ca =
    try
      let c = img#colors in
      msg (ok 2 "obtained color allocator instance");
      c
    with _ -> failwith "Failed to get color allocator." in
  let white =
    try
      let w = ca#white in
      msg (ok 3 "allocated white");
      w
    with _ -> failwith "Failed to get white."
  and ltblue, maroon, orange, aqua, grey, brown =
    try
      let more =
        ca#create 127 127 255, ca#create 127 0 0, ca#create 191 127 0,
        ca#create 0 153 204, ca#create 153 153 153, ca#create 127 127 0 in
      msg (ok 4 "allocated additional colors");
      more
    with _ -> failwith "Failed to create additional colors." in
  begin
    try
      img#rectangle 10 10 180 140 maroon;
      msg (ok 5 "drew outline rectangle")
    with _ -> msg (failed 5 "Failed to draw outline rectangle.")
  end;
  begin
    try
      img#filled_rectangle 50 40 220 170 ltblue;
      msg (ok 6 "drew filled rectangle")
    with _ -> msg (failed 6 "Failed to draw filled rectangle.")
  end;
  begin
    try
      img#set_antialiased aqua;
      begin
        try
          img#arc ~cx:108 ~cy:276 ~w:192 ~h:128 ~s:0 ~e:270 
            ~pseudo:(ca#antialiased ()) aqua;
          msg (ok 7 "drew partial outline arc with antialiased pseudocolor")
        with _ -> msg (failed 7 "Failed to draw partial outline arc.")
      end
    with _ -> msg (failed 7 "Failed to set antialiased color.")
  end;
  begin
    try
      img#filled_ellipse 144 300 192 128 grey;
      msg (ok 8 "drew filled ellipse")
    with _ -> msg (failed 8 "Failed to draw filled ellipse.")
  end;
  begin
    try
      img#set_antialiased brown;
      begin
        try
          img#polygon
            ~pts:[|280,80;340,32;440,48;440,144;360,144;280,108;280,80|] 
            ~pseudo:(ca#antialiased ()) brown;
          msg (ok 9 "drew outline polygon with antialiased pseudocolor")
        with _ -> msg (failed 9 "Failed to draw polygon.")
      end
    with _ -> msg (failed 9 "Failed to set antialiased color.")
  end;
  begin
    try
      img#filled_polygon 
        [|320,110;380,62;480,78;480,174;400,174;320,138;320,110|] orange;
      msg (ok 10 "drew filled polyon")
    with _ -> msg (failed 10 "Failed to draw filled polygon.")
  end;
  begin
    try
      img#string
        ~x:244 ~y:228 ~font:Gd.Font.giant 
        ~s:"As I was coming up the stair," orange;
      msg (ok 11 "drew string 1")
    with _ -> msg (failed 11 "Failed to draw string 1.")
  end;
  begin
    try
      img#string
        ~x:254 ~y:260 ~font:Gd.Font.large 
        ~s:"I met a man who wasn't there." grey;
      msg (ok 12 "drew string 2")
    with _ -> msg (failed 12 "Failed to draw string 2.")
  end;
  begin
    try
      img#string
        ~x:264 ~y:290 ~font:Gd.Font.medium
        ~s:"He wasn't there again today!" aqua;
      msg (ok 13 "drew string 3")
    with _ -> msg (failed 13 "Failed to draw string 3.")
  end;
  begin
    try
      img#string
        ~x:274 ~y:318 ~font:Gd.Font.small 
        ~s:"I wish, I wish, he'd go away." maroon;
      msg (ok 14 "drew string 4")
    with _ -> msg (failed 14 "Failed to draw string 4.")
  end;
  img#save_as_png (Filename.concat tempdir "shapes_test.png");
  write_footer msg_ch "END SHAPES"


let color_allocation_test msg_ch =
  write_header msg_ch "COLOR ALLOCATION"
    ("Create an 8-bit image and a truecolor image, and attempt to allocate\n"^
     "a large number of colors in each. The test should fail at index 256 \n"^
     "for the 8-bit image, and should *not* fail for the truecolor image.");
  let msg = output_string msg_ch in
  let rgbvals = [|0; 31; 63; 95; 127; 159; 191; 223; 255|] in
  let numvals = Array.length rgbvals in
  let last = numvals - 1 in
  let do_colors img is_tc testno =
    let (ca : color_allocator) = img#colors
    and index = ref 0 in
    try
      for r = 0 to last do
        for g = 0 to last do
          for b = 0 to last do
            index := (r * numvals * numvals + g * numvals + b);
            ignore (ca#create rgbvals.(r) rgbvals.(g) rgbvals.(b))
          done;
        done;
      done;
      if is_tc then
        msg (ok testno "Truecolor - all colors successfully allocated.")
      else
        msg (failed testno "8bit - too many colors allocated without error.")
    with
    | Too_many_colors ->
      if is_tc then
        msg (failed testno ("Truecolor - failed at index " ^ 
                             string_of_int !index ^ ".")) else
      if !index = 256 then
        msg (ok testno "8bit - failed at index 256.") 
      else
        msg (failed testno ("8bit - failed at index " ^ 
                             string_of_int !index ^ "."))
    | _ ->
      if is_tc then msg (failed testno ("Truecolor - unknown exception " ^ 
                                        "at index " ^
                                        string_of_int !index ^ "."))
      else msg (failed testno ("8bit - unknown exception at index " ^
                                string_of_int !index ^ ".")) in
  do_colors (create 256 256) false 1;
  do_colors (create_truecolor 256 256) true 2;
  write_footer msg_ch "END COLOR ALLOCATION"

      
let copy_resize_test msg_ch =
  write_header msg_ch "COPYING AND RESIZING"
    ( "Test copying and resizing functions.\n" ^
      "1. Copy a small image into a larger image with 'copy'.\n" ^
      "2. Copy a portion of an image into a larger image with 'copy'.\n" ^
      "3. Copy a small image into a larger image with 'copy_resized'.\n" ^
      "4. Copy a small image into a larger image with 'copy_resampled'.\n" ^
      "   Compare the output with that of test #2; details should be\n" ^
      "   smoother.\n" ^
      "5. Copy a small image into a larger image with 'copy_rotated'.\n" ^
      "6. Copy a small image into a larger image with 'copy_merge'.\n" ^
      "7. Copy a small image into a larger image with 'copy_merge_gray'.\n" ^
      "8. Create a new image, copy the palette from an existing image,\n" ^
      "   then copy the contents of the second image. If the palette is\n" ^
      "   copied correctly, this should produce a copy whose colors and\n" ^
      "   dimensions are identical to the original.\n");
  let msg = output_string msg_ch in
  let indexed_img1 = "yotei02-8.png"
  and truecolor_img1 = "yotei02-t.png"
  and indexed_img2 = "driver01-8.png"
  and truecolor_img2 = "driver01-t.png"
  and indexed_img3 = "kamokamogawa04-8.png"
  and truecolor_img3 = "kamokamogawa04-t.png" in
  let img_path name = 
    Filename.concat "." (Filename.concat "samples" name) in

  let get_dims dst src = dst#width, dst#height, src#width, src#height in
  
  let test1 img1 img2 =
    let dst = open_png (img_path img1)
    and src = open_png (img_path img2) in
    try
      let outfile = "copy.png" in
      let dw, dh, sw, sh = get_dims dst src in    
      dst#copy src ~x:((dw - sw) / 2) ~y:((dh - sh) / 2)
        ~src_x:0 ~src_y:0 ~w:sw ~h:sh;
      dst#save_as_png (Filename.concat tempdir outfile);
      msg (ok 1 ("Saved " ^ outfile ^ "."))
    with _ ->
      msg (failed 1 "image#copy test failed.")

  and test2 img1 img2 =
    let dst = open_png (img_path img1)
    and src = open_png (img_path img2) in
    try
      let outfile = "copy(crop).png" in
      let dw, dh, sw, sh = get_dims dst src in    
      let crop_x = int_of_float ((float_of_int sw) *. 0.35)
      and crop_y = int_of_float ((float_of_int sh) *. 0.35) in
      dst#copy src ~x:(dw / 2) ~y:(dh / 2)
        ~src_x:crop_x ~src_y:crop_y ~w:(sw / 2) ~h:(sh / 2);
      dst#save_as_png (Filename.concat tempdir outfile);
      msg (ok 2 ("Saved " ^ outfile ^ "."))
    with _ ->
      msg (failed 2 "image#copy cropping test failed.")

  and test3 img1 img2 =
    let dst = open_png (img_path img1)
    and src = open_png (img_path img2) in
    try
      let outfile = "copy_resized.png" in 
      let dw, dh, sw, sh = get_dims dst src in    
      let new_w = (int_of_float ((float_of_int sw) *. 0.75))
      and new_h = (int_of_float ((float_of_int sh) *. 1.1)) in
      dst#copy_resized src ~x:((dw - new_w) / 2) ~y:((dh - new_h) / 2)
        ~src_x:0 ~src_y:0 ~src_w:sw ~src_h:sh ~w:new_w ~h:new_h;
      dst#save_as_png (Filename.concat tempdir outfile);
      msg (ok 3 ("Saved " ^ outfile ^ "."))
    with _ ->
      msg (failed 3 "image#copy_resized test failed.")

  and test4 img1 img2 =
    let dst = open_png (img_path img1)
    and src = open_png (img_path img2) in
    try
      let outfile = "copy_resampled.png" in
      let dw, dh, sw, sh = get_dims dst src in    
      let new_w = (int_of_float ((float_of_int sw) *. 0.75))
      and new_h = (int_of_float ((float_of_int sh) *. 1.1)) in
      dst#copy_resampled src ~x:((dw - new_w) / 2) ~y:((dh - new_h) / 2)
        ~src_x:0 ~src_y:0 ~src_w:sw ~src_h:sh ~w:new_w ~h:new_h;
      dst#save_as_png (Filename.concat tempdir outfile);
      msg (ok 4 ("Saved " ^ outfile ^ "."))
    with _ ->
      msg (failed 4 "image#copy_resampled test failed.")

  and test5 img1 img2 =
    let dst = open_png (img_path img1)
    and src = open_png (img_path img2) in
    try
      let outfile = "copy_rotated.png" in
      let dw, dh, sw, sh = get_dims dst src in    
      let cx = (float_of_int dw) /. 2.
      and cy = (float_of_int dh) /. 2. in
      dst#copy src ~x:((dw - sw) / 2) ~y:((dh - sh) / 2)
        ~src_x:0 ~src_y:0 ~w:sw ~h:sh;
      dst#copy_rotated src ~x:cx ~y:cy
        ~src_x:0 ~src_y:0 ~w:sw ~h:sh ~angle:30;
      dst#copy_rotated src ~x:cx ~y:cy
        ~src_x:0 ~src_y:0 ~w:sw ~h:sh ~angle:60;
      dst#copy_rotated src ~x:cx ~y:cy
        ~src_x:0 ~src_y:0 ~w:sw ~h:sh ~angle:90;
      dst#save_as_png (Filename.concat tempdir outfile);
      msg (ok 5 ("Saved " ^ outfile ^ "."))
    with _ ->
      msg (failed 5 "image#copy_rotated test failed.")

  and test6 img =
    let src = open_png (img_path img) in
    let sw = src#width
    and sh = src#height in
    let dw = sw * 2
    and dh = sh * 2 in
    let dst = create ~x:dw ~y:dh in
    try
      let outfile = "copy_merge.png" in
      let dw, dh, sw, sh = get_dims dst src in
      let ca = dst#colors in
      ignore (ca#create 0 204 153);
      dst#copy_merge src ~x:((dw - sw) / 2) ~y:((dh - sh) / 2)
        ~src_x:0 ~src_y:0 ~w:sw ~h:sh ~pct:50;
      dst#save_as_png (Filename.concat tempdir outfile);
      msg (ok 6 ("Saved " ^ outfile ^ "."))
    with _ ->
      msg (failed 6 "image#copy_merge test failed.")

  and test7 img =
    let src = open_png (img_path img) in
    let sw = src#width
    and sh = src#height in
    let dw = sw * 2
    and dh = sh * 2 in
    let dst = create ~x:dw ~y:dh in
    try
      let outfile = "copy_merge_gray.png" in
      let dw, dh, sw, sh = get_dims dst src in
      let ca = dst#colors in
      ignore (ca#create 0 204 153);
      dst#copy_merge_gray src ~x:((dw - sw) / 2) ~y:((dh - sh) / 2)
        ~src_x:0 ~src_y:0 ~w:sw ~h:sh ~pct:50;
      dst#save_as_png (Filename.concat tempdir outfile);
      msg (ok 7 ("Saved " ^ outfile ^ "."))
    with _ ->
      msg (failed 7 "image#copy_merge_gray test failed.")

  and test8 img =
    let src = open_png (img_path img) in
    let sw = src#width
    and sh = src#height in
    let dw = sw
    and dh = sh in
    let dst = create ~x:dw ~y:dh in
    try
      let outfile = "palette_copy.png" in
      let dw, dh, sw, sh = get_dims dst src in    
      dst#palette_copy src;
      dst#copy src ~x:0 ~y:0 ~src_x:0 ~src_y:0 ~w:sw ~h:sh;
      dst#save_as_png (Filename.concat tempdir outfile);
      msg (ok 8 ("Saved " ^ outfile ^ "."))
    with _ ->
      msg (failed 8 "image#palette_copy test failed.") in

  test1 indexed_img1 indexed_img2;
  test2 indexed_img1 indexed_img2;
  test3 truecolor_img1 indexed_img2;
  test4 truecolor_img1 indexed_img2;
  test5 truecolor_img1 truecolor_img2;
  test6 indexed_img2;
  test7 indexed_img2;
  test8 indexed_img3;

  write_footer msg_ch "END COPYING AND RESIZING"


let io_test msg_ch =
  write_header msg_ch "INPUT/OUTPUT"
    ( "Test loading and saving functions.\n" ^
      "1. Save to PNG with 'save_to_png'.\n" ^
      "2. Save to JPEG with 'save_to_jpeg,' quality 100.\n" ^
      "3. Save to JPEG with 'save_to_jpeg,' quality 60.\n" ^
      "4. Save to PNG with 'open_out' -> 'out_as_png'.\n" ^
      "5. Save to JPEG with 'open_out' -> 'out_as_jpeg'.\n"); 
  let msg = output_string msg_ch in
  let draw () =
    let img = create 256 256 in
    let ca = img#colors in
    let white = ca#white
    and red = ca#create 255 0 0
    and black = ca#black in
    img#filled_ellipse 64 64 100 100 red;
    img#filled_ellipse 192 64 100 100 black;
    img#filled_ellipse 64 192 100 100 black;
    img#filled_ellipse 192 192 100 100 red;
    img in
  let fname = (Filename.concat tempdir "io_test-d.png")
  and im = draw () in
  begin
    try
      im#save_as_png fname;
      msg (ok 1 "Saved " ^ fname)
    with _ -> msg (failed 1 "Failed to save " ^ fname)
  end;
  
  let fname = Filename.concat tempdir "io_test-d-100.jpg"
  and im = draw () in
  begin
    try
      im#save_as_jpeg ~quality:100 fname;
      msg (ok 2 "Saved " ^ fname);
    with _ -> msg (failed 2 "Failed to save " ^ fname)
  end;
  
  let fname = Filename.concat tempdir "io_test-d-60.jpg"
  and im = draw () in
  begin
    try
      im#save_as_jpeg ~quality:60 fname;
      msg (ok 3 "Saved " ^ fname);
    with _ -> msg (failed 3 "Failed to save " ^ fname)
  end;
  
  let fname = Filename.concat tempdir "io_test-i.png"
  and im = draw ()
  and oc = open_out fname in
  begin
    try
      im#out_as_png oc;
      msg (ok 4 "Saved " ^ fname);
    with _ -> msg (failed 4 "Failed to save " ^ fname)
  end;
  close_out oc;
  
  let fname = Filename.concat tempdir "io_test-i.jpg"
  and im = draw ()
  and oc = open_out fname in
  begin
    try
      im#out_as_jpeg oc;
      msg (ok 5 "Saved " ^ fname);
    with _ -> msg (failed 5 "Failed to save " ^ fname)
  end;
  close_out oc;
  write_footer msg_ch "END INPUT/OUTPUT"


let ft_test msg_ch fonts =
  try
    let [ f1; f2; f3; f4 ] = fonts in
    write_header msg_ch "TRUETYPE FONT RENDERING"
      ( "Test of #image#string_ft. Create an image with a white\n" ^
        "background and four strings with the following properties:\n" ^
        "  1. 24pt, blue, start at x:60,y:236, slopes upward 30 deg.\n" ^
        "  2. 18pt, grey, start at x:60,y:272\n" ^
        "  3. 12pt, red, start at x:60,y:96\n" ^
        "  4. 8pt, black, start at x:60,y:316\n" ^
        "Save output as 'ft_test.png'.");
    let msg = output_string msg_ch in
    let im = create 512 384 in
    let ca = im#colors in
    let white = ca#white
    and black = ca#black
    and grey = ca#create 153 153 153
    and red = ca#create 204 0 0
    and blue = ca#create 47 47 255 in
    ignore (im#string_ft blue f1 24.0 (deg2rad 30.) 60 236 
      "As I was coming up the stair,");
    msg (ok 1 "Rendered first string.");
    ignore (im#string_ft grey f2 18.0 0.0 60 272 
      "I met a man who wasn't there.");
    msg (ok 2 "Rendered second string.");
    ignore (im#string_ft red f3 12.0 0.0 60 296 
      "He wasn't there again today!");
    msg (ok 3 "Rendered third string.");
    ignore (im#string_ft black f4 8.0 0.0 60 316 
      "I wish, I wish, he'd go away.");
    msg (ok 4 "Rendered fourth string.");
    im#save_as_png (Filename.concat tempdir "ft_test.png");
    write_footer msg_ch "END TRUETYPE FONT RENDERING"
  with Match_failure _ ->
    prerr_endline 
      "The TrueType font test requires a list of four font files."
      

let ftex_test msg_ch fonts =
  try
    let fnt = List.hd fonts in
    write_header msg_ch "TRUETYPE FONT EXTENDED RENDERING"
      ( "Test of #image#string_ftex. Create an image with a white\n" ^
        "background and a four-line poem in black 14pt type, widely\n" ^
        "spaced (2.5 * line height); save output as 'ftex_test.png'.");
    let msg = output_string msg_ch in
    let im = create 512 384 in
    let ca = im#colors in
    let white = ca#white
    and black = ca#black in
    let poem = ( "As I was coming up the stair,\n" ^ 
      "I met a man who wasn't there.\n" ^
      "He wasn't there again today!\n" ^
      "I wish, I wish he'd go away." ) in
    ignore (im#string_ftex ~fg:black ~fname:fnt ~size:14.0 ~angle:0.0
      ~x:100 ~y:80 ~flags:[|FTExSetSpacing|] ~spacing:2.5 poem);
    msg (ok 1 "Rendered poem.");
    im#save_as_png (Filename.concat tempdir "ftex_test.png");
    msg (ok 2 "Saved to 'ftex_test.png'");
    write_footer msg_ch "END TRUETYPE FONT EXTENDED RENDERING"
  with Match_failure _ ->
    prerr_endline 
      "The TrueType font test requires a list of four font files."

let ft_tests msg_ch =
  let rec getfonts ch fnts =
    if List.length fnts >= 4 then fnts
    else
      ( try
          let line = input_line ch in
          if Str.string_match skiplineRE line 0 then
            getfonts ch fnts
          else
            getfonts ch (line :: fnts)
        with End_of_file -> fnts ) in
  if Sys.file_exists "font.list" then
    let ic = open_in "font.list" in
    let fonts = List.rev (getfonts ic []) in
    close_in ic;
    ft_test msg_ch fonts;
    ftex_test msg_ch fonts
  else
    prerr_endline
      ( "IMPORTANT: if you wish to run the TrueType font rendering tests,\n" ^
        "you must have a file named 'font.list' which contains the full\n" ^
        "pathnames of four font files that exist on your system. For an\n" ^
        "example, see 'font_list.txt'" )
      

let test msg_ch =
  color_allocation_test msg_ch;
  shapes_test msg_ch;
  copy_resize_test msg_ch;
  io_test msg_ch;
  ft_tests msg_ch


let _ =
  prerr_endline ("::::::::::::::::::::::::::::::::::::" ^
                 "::::::::::::::::::::::::::::::::::::");
  prerr_endline ("Starting tests. Files will be saved in " ^ tempdir ^ ".");
  prerr_endline ("::::::::::::::::::::::::::::::::::::" ^
                 "::::::::::::::::::::::::::::::::::::");
  if Array.length Sys.argv >= 2 then
    let logfile = Sys.argv.(1) in
    let msgchannel = open_out logfile in
    test msgchannel;
    prerr_endline ("Tests completed. For details, see " ^ logfile ^ ".");
    close_out msgchannel
  else
    begin
      test stderr;
      prerr_endline "Tests completed."
    end