Annotation of scaleomat/scaleomat.pl, revision 1.10
1.1 casties 1: #!/usr/bin/perl
2:
1.9 casties 3: # Copyright (C) 2003-2005 Robert Casties, IT-Group MPIWG
1.3 casties 4: #
5: # This program is free software; you can redistribute it and/or modify it
6: # under the terms of the GNU General Public License as published by the Free
7: # Software Foundation; either version 2 of the License, or (at your option)
8: # any later version.
9: #
10: # Please read license.txt for the full details. A copy of the GPL may be found
11: # at http://www.gnu.org/copyleft/lgpl.html
12: #
13: # You should have received a copy of the GNU General Public License along with
14: # this program; if not, write to the Free Software Foundation, Inc., 59 Temple
15: # Place, Suite 330, Boston, MA 02111-1307 USA
16:
1.2 casties 17: use strict;
1.4 casties 18: use sigtrap qw(die normal-signals);
1.2 casties 19:
20: # MPIWG libraries
21: use lib '/usr/local/mpiwg/scripts';
22: use MPIWGlib;
23:
24:
1.1 casties 25: $| = 1; # unblock IO
26:
1.10 ! casties 27: my $version = "V0.9.7 (ROC 27.4.2005)";
1.1 casties 28:
29: $debug = 0;
30:
1.2 casties 31: my $simulate = 0;
32:
33: my $do_descend = 1;
1.1 casties 34:
1.2 casties 35: my $dir_perm = 0775;
36: my $file_perm = 0664;
1.1 casties 37:
38: umask 000; # to make shure we can actually use these perms
39:
1.2 casties 40: my $overwrite = 0; # overwrite already converted files
1.9 casties 41: my $synchronise = 0; # delete unmatched destination files
1.1 casties 42:
1.2 casties 43: # image file extensions and formats
44: my %img_type_ext = ("tif" => "TIFF", "tiff" => "TIFF", "gif" => "GIF",
1.6 casties 45: "jpg" => "JPEG", "png" => "PNG", "dcr" => "RAW");
1.2 casties 46: # destination image file extensions
47: my %target_ext_type = ("TIFF" => "jpg", "JPEG" => "jpg");
48:
49: # default scale settings
1.7 casties 50: my $scale_w = 2048; # width in pixel
51: my $scale_h = 2048; # height in pixel
1.2 casties 52: my $scale_relative = 0; # scale by relative factor instead of destination size
53: my $jpeg_quality = 75; # default JPEG compression quality
1.9 casties 54: my $use_encoder = 0; # false: autodetect encoder
1.2 casties 55:
56: # programs to use
57: my $identifier;
58: my $tiffinfo;
59: my $jpegloader;
60: my $tiffloader;
61: my $quantizer;
62: my $scaler;
63: my $jpegwriter;
64: my $pngwriter;
65: my $converter;
1.1 casties 66:
67: ##########################################################################
68: # subroutines
69: #
70:
71: #
72: # checksoft()
73: #
74: # returns if all necessary external programs are installed
75: #
76: sub checksoft {
77:
78: my @softdirs = ("/usr/X11R6/bin", "/usr/bin", "/usr/local/bin");
79:
80: $identifier = findfile(\@softdirs, "identify")
81: or die("ABORT: neccessary external program not found: identify");
1.2 casties 82: $tiffinfo = findfile(\@softdirs, "tiffinfo")
83: or die("ABORT: neccessary external program not found: tiffinfo");
1.1 casties 84: $jpegloader = findfile(\@softdirs, "jpegtopnm")
85: or die("ABORT: neccessary external program not found: jpegtopnm");
86: $tiffloader = findfile(\@softdirs, "tifftopnm")
87: or die("ABORT: neccessary external program not found: tifftopnm");
88: $quantizer = findfile(\@softdirs, "pbmtopgm")
89: or die("ABORT: neccessary external program not found: pbmtopgm");
90: $scaler = findfile(\@softdirs, "pnmscale")
91: or die("ABORT: neccessary external program not found: pnmscale");
92: $jpegwriter = findfile(\@softdirs, "ppmtojpeg")
93: or die("ABORT: neccessary external program not found: ppmtojpeg");
94: $pngwriter = findfile(\@softdirs, "pnmtopng")
95: or die("ABORT: neccessary external program not found: pnmtopng");
96: $converter = findfile(\@softdirs, "convert")
97: or die("ABORT: neccessary external program not found: convert");
98:
99: }
100:
101:
102:
103: #
104: # findir(\@basedirs, $subdir)
105: #
106: # check directories in @basedirs+$subdir and return the first existing basedir
107: #
108: sub findir {
109: my($dirlist, $subdir) = @_;
110:
111: foreach my $dir (@$dirlist) {
112: if (-d "$dir/$subdir") {
113: return "$dir";
114: }
115: }
116: return;
117: }
118:
119: #
120: # findfile(\@basedirs, $filename)
121: #
122: # check @basedirs+$filename and return the first existing file
123: #
124: sub findfile {
125: my($dirlist, $fn) = @_;
126:
127: foreach my $dir (@$dirlist) {
128: if (-f "$dir/$fn") {
129: return "$dir/$fn";
130: }
131: }
132: return;
133: }
134:
1.5 casties 135: #
136: # $p = cleanpath($path, $startslash).
137: #
138: # returns a pathname with trailing and starting slash removed (if
139: # $startslash is true the starting slash is not removed)
140: #
1.4 casties 141: sub cleanpath {
142: my ($path, $startslash) = @_;
143:
144: if ($path =~ /^(\/)*(.*?)\/*$/) {
145: if ($startslash) {
146: return $1 . $2;
147: } else {
148: return $2;
149: }
150: }
151: return $path;
152: }
153:
1.1 casties 154: #
1.2 casties 155: # ($basename, $extension) = splitfn($filename)
156: #
157: # split filename into base and (lowercase) extension
158: #
159: sub splitfn {
160: my ($filepath) = @_;
161: if ($filepath =~ /^(.*)\.(\w+)$/) {
162: return ($1, lc($2));
163: }
164: return;
165: }
166:
167:
168: #
1.1 casties 169: # mmkdir($dirname)
170: #
171: # create directory recursively and check permissions
172: #
173: sub mmkdir {
174: my($dirname) = @_;
175: my $newdir;
176:
177: # does the directory already exist?
1.2 casties 178: if (-d $dirname) {
179: chmod $dir_perm, $dirname or do {
1.4 casties 180: logger('WARNING', "unable to change permission on $dirname!");
1.1 casties 181: };
182: return 1;
183: }
184: # split directory name by levels
185: my @dirlist = split /\//, $dirname;
186: my @newlist = ();
187: my $dir = join("/", @dirlist);
188: # test backwards which directories exist
189: while (not -d $dir) {
1.2 casties 190: last unless ($dir);
1.1 casties 191: # move missing elements from the end of @dirlist to @newlist
192: unshift @newlist, pop @dirlist;
193: $dir = join("/", @dirlist);
194: }
195: # create missing directories level by level
196: foreach $newdir (@newlist) {
197: push @dirlist, $newdir;
198: $dir = join("/", @dirlist);
199: mkdir "$dir", $dir_perm or do {
1.2 casties 200: logger('ERROR', "unable to create $dir!");
1.1 casties 201: return 0;
202: }
203: }
204: return 1;
205: }
206:
207: #
1.2 casties 208: # ($type, $width, $height) = identify($filepath)
209: #
1.9 casties 210: # returns type, width and height of the image using ImageMagick's identify
211: #
1.2 casties 212: sub identify {
213: my ($filepath) = @_;
1.4 casties 214: my $pictype = "";
215: my $picwidth = 0;
216: my $picheight = 0;
1.2 casties 217: my $bitdepth = 0;
218: # use quickident first
219: $pictype = quickident($filepath);
1.7 casties 220: # optimized tiff identification
1.2 casties 221: if (($pictype)&&($pictype eq 'TIFF')) {
222: logger('DEBUG', "running tiffinfo $tiffinfo");
223: if (open(IDENT, "nice -10 $tiffinfo '$filepath' 2>/dev/null |")) {
224: while (<IDENT>) {
225: chomp;
1.7 casties 226: # we take the biggest values, because embedded thumbnails
227: # may also show up
1.2 casties 228: if (/Image Width:\s*(\d+)\s*Image Length:\s*(\d+)/) {
1.4 casties 229: $picwidth = $1 if ($1 > $picwidth);
230: $picheight = $2 if ($2 > $picheight);
1.2 casties 231: next;
232: }
233: if (/Bits\/Sample:\s*(\d+)/) {
1.4 casties 234: $bitdepth = $1 if ($1 > $bitdepth);
1.2 casties 235: next;
236: }
237: }
238: if ($picwidth) {
1.4 casties 239: logger('DEBUG', "TIFF $picwidth x $picheight");
1.2 casties 240: return ($pictype, $picwidth, $picheight, $bitdepth);
241: }
242: }
243: }
244: # run ident to get image type and dimensions
245: logger('DEBUG', "running identifier $identifier");
246: if (open(IDENT, "nice -10 $identifier -ping -format '%w %h %m\n' '$filepath' 2>/dev/null |")) {
247: my @id = <IDENT>;
248: my $picinfo = $id[0];
249: close IDENT;
250: chomp $picinfo;
251: logger('DEBUG', "PIC is '$picinfo'");
252: if ($picinfo =~ /^(\d+) (\d+) (\w+)$/) {
253: $picwidth = $1;
254: $picheight = $2;
255: $pictype = $3;
256: }
257: } else {
258: logger('DEBUG', "unable to identify $filepath!");
259: }
260: return ($pictype, $picwidth, $picheight, $bitdepth);
261: }
262:
263: #
264: # $type = quickident($filepath);
265: #
1.9 casties 266: # returns image type based on file extension only
267: #
1.2 casties 268: sub quickident {
269: my ($filepath) = @_;
270: logger('DEBUG', "running quickident");
271: # look at file extension
272: my ($filebase, $fileext) = splitfn($filepath);
273: if ($fileext) {
274: return $img_type_ext{$fileext};
275: }
276: return;
277: }
278:
279:
280: #
1.7 casties 281: # $fact = scalefactor(\$args)
1.1 casties 282: #
1.9 casties 283: # returns the necessary scaling factor
284: #
1.7 casties 285: sub scalefactor {
1.2 casties 286: my ($args) = @_;
287:
288: my $srcdir = $$args{'srcdir'};
289: my $filename = $$args{'filename'};
1.7 casties 290: my $scale_w = $$args{'scale_w'};
291: my $scale_h = $$args{'scale_h'};
1.2 casties 292: my $scale_rel = $$args{'scale_rel'};
1.7 casties 293: my $scale = 0;
1.2 casties 294:
295: if ($scale_rel) {
296: # scale relative -- no size needed, only scaling factor
1.7 casties 297: $scale = $scale_w;
1.2 casties 298: } else {
299: # scale to size -- size needed
300: my $pictype = $$args{'pictype'};
301: my $picwidth = $$args{'picwidth'};
302: my $picheight = $$args{'picheight'};
303: if (! $picwidth) {
1.7 casties 304: # no size yet - identify
1.2 casties 305: ($pictype, $picwidth, $picheight) = identify("$srcdir/$filename");
306: if ((! $pictype)||($picwidth == 0)||($picheight == 0)) {
307: logger('ERROR', "unable to identify $srcdir/$filename!");
1.7 casties 308: return 0;
1.2 casties 309: }
1.7 casties 310: # save values
311: $$args{'pictype'} = $pictype;
312: $$args{'picwidth'} = $picwidth;
313: $$args{'picheight'} = $picheight;
314: }
315: # calculate x and y scaling factors
316: my $scale_x = $scale_w / $picwidth;
317: my $scale_y = $scale_h / $picheight;
318: # take the smallest
319: if ($scale_x < $scale_y) {
320: $scale = $scale_x;
321: logger('DEBUG', "PIC scale to width");
1.2 casties 322: } else {
1.7 casties 323: $scale = $scale_y;
324: logger('DEBUG', "PIC scale to height");
1.2 casties 325: }
1.7 casties 326: if ($scale >= 1) {
327: $scale = 1;
1.2 casties 328: logger('DEBUG', "PIC is already smaller");
1.7 casties 329: # continue since we may have to convert
1.2 casties 330: }
331: }
1.7 casties 332: return $scale;
333: }
334:
335:
336: #
337: # $error = scale_jpeg(\$args);
338: #
339: # scale JPEG images to JPEG using netpbm tools
340: #
341: # args needed: $srcdir, $filename, $destdir,
342: # $scale_w, $scale_h, $scale_rel, $picwidth, $picheight
343: #
344: sub scale_jpeg {
345: my ($args) = @_;
346:
347: my $srcdir = $$args{'srcdir'};
348: my $filename = $$args{'filename'};
349: my $destdir = $$args{'destdir'};
350: my $scale_w = $$args{'scale_w'};
351: my $scale_h = $$args{'scale_h'};
352: my $scale_rel = $$args{'scale_rel'};
353: my $scaleopt;
354:
355: # convert jpg -> jpg
356: my ($basename, $fileext) = splitfn($filename);
357: my $newfn = $basename . ".jpg";
358: logger('INFO', "Convert(jpg): $filename -> $newfn");
359: return 1 if ($simulate);
360:
361: $scaleopt = scalefactor($args);
1.1 casties 362:
1.2 casties 363: if (!$scaleopt) {
364: logger('ERROR', "unable to calculate scaling options!");
365: return 1;
1.1 casties 366: }
1.2 casties 367:
1.8 casties 368: if ($scaleopt == 1) {
1.7 casties 369: # is already smaller
1.8 casties 370: logger('DEBUG', "PIC is smaller and JPEG - ignoring");
1.7 casties 371: return 0;
372: }
373:
1.2 casties 374: # convert
375: logger('DEBUG', "nice -10 $jpegloader '$srcdir/$filename' 2>/dev/null | nice -10 $scaler $scaleopt 2>/dev/null | nice -10 $jpegwriter > '$destdir/$newfn' 2>/dev/null");
376: return 0 if ($simulate);
377: if (system("nice -10 $jpegloader '$srcdir/$filename' 2>/dev/null | nice -10 $scaler $scaleopt 2>/dev/null | nice -10 $jpegwriter > '$destdir/$newfn' 2>/dev/null") != 0) {
378: logger('ERROR', "error converting '$srcdir/$filename'!");
1.7 casties 379: if (! -s "$destdir/$newfn") {
380: # file broken (size 0)
381: logger('ERROR', "created file '$destdir/$newfn' broken -- will be removed!");
382: unlink "$destdir/$newfn";
383: }
1.2 casties 384: return 1;
1.1 casties 385: }
1.2 casties 386:
387: # change permissions
388: chmod $file_perm, "$destdir/$newfn" or
389: logger('WARNING', "unable to set permission on '$destdir/$newfn'");
390:
391: if (! -s "$destdir/$newfn") {
392: # file broken (size 0)
393: logger('ERROR', "created file '$destdir/$newfn' broken -- will be removed!");
394: unlink "$destdir/$newfn";
395: return 1;
1.1 casties 396: }
1.2 casties 397: return 0;
1.1 casties 398: }
399:
400:
401: #
1.2 casties 402: # $error = scale_tiff_jpeg2(\$args);
403: #
404: # scale TIFF images to JPEG using ImageMagick convert
1.1 casties 405: #
1.2 casties 406: # args needed: $srcdir, $filename, $destdir,
1.7 casties 407: # $scale_w, $scale_h, $scale_rel, $picwidth, $picheight
1.1 casties 408: #
1.2 casties 409: sub scale_tiff_jpeg2 {
410: my ($args) = @_;
411:
412: my $srcdir = $$args{'srcdir'};
413: my $filename = $$args{'filename'};
414: my $destdir = $$args{'destdir'};
1.7 casties 415: my $scale_w = $$args{'scale_w'};
416: my $scale_h = $$args{'scale_h'};
1.2 casties 417: my $scale_rel = $$args{'scale_rel'};
418: my $scaleopt;
419:
420: my ($basename, $fileext) = splitfn($filename);
421: my $newfn = $basename . ".jpg";
422: logger('INFO', "Convert(tiff2): $filename -> $newfn");
423:
424: if ($scale_rel) {
1.7 casties 425: my $per_scale = 100 * $scale_w;
1.2 casties 426: logger('DEBUG', "nice -10 $converter -quality $jpeg_quality -scale $per_scale\% '$srcdir/$filename' '$destdir/$newfn' 2>/dev/null");
427: return 0 if ($simulate);
428: if (system("nice -10 $converter -quality $jpeg_quality -scale $per_scale\% '$srcdir/$filename' '$destdir/$newfn' 2>/dev/null\n") != 0) {
429: logger('ERROR', "error converting '$srcdir/$filename'!");
430: return 1;
431: }
432: } else {
1.7 casties 433: logger('DEBUG', "nice -10 $converter -quality $jpeg_quality -scale ${scale_w}x${scale_h} '$srcdir/$filename' '$destdir/$newfn' 2>/dev/null");
1.2 casties 434: return 0 if ($simulate);
1.7 casties 435: if (system("nice -10 $converter -quality $jpeg_quality -scale ${scale_w}x${scale_h} '$srcdir/$filename' '$destdir/$newfn' 2>/dev/null\n") != 0) {
1.2 casties 436: logger('ERROR', "error converting '$srcdir/$filename'!");
1.7 casties 437: if (! -s "$destdir/$newfn") {
438: # file broken (size 0)
439: logger('ERROR', "created file '$destdir/$newfn' broken -- will be removed!");
440: unlink "$destdir/$newfn";
441: }
1.2 casties 442: return 1;
1.1 casties 443: }
444: }
1.2 casties 445:
446: # change permissions
447: chmod $file_perm, "$destdir/$newfn" or
448: logger('WARNING', "unable to set permission on '$destdir/$newfn'");
449:
450: return 0;
451: }
452:
453:
454: #
455: # $error = scale_tiff_jpeg(\$args);
456: #
457: # scale TIFF images to JPEG using netpbm tools
458: #
459: # args needed: $srcdir, $filename, $destdir,
1.7 casties 460: # $scale_w, $scale_h, $scale_rel, $picwidth, $picheight
1.2 casties 461: #
462: sub scale_tiff_jpeg {
463: my ($args) = @_;
464:
465: my $srcdir = $$args{'srcdir'};
466: my $filename = $$args{'filename'};
467: my $destdir = $$args{'destdir'};
1.7 casties 468: my $bitdepth = $$args{'bitdepth'};
469: my $scale_w = $$args{'scale_w'};
470: my $scale_h = $$args{'scale_h'};
1.2 casties 471: my $scale_rel = $$args{'scale_rel'};
472: my $scaleopt;
473:
474: # convert jpg -> jpg
475: my ($basename, $fileext) = splitfn($filename);
476: my $newfn = $basename . ".jpg";
477: logger('INFO', "Convert(tiff1): $filename -> $newfn");
478: return 1 if ($simulate);
479:
1.7 casties 480: $scaleopt = scalefactor($args);
1.2 casties 481:
482: if (!$scaleopt) {
483: logger('ERROR', "unable to calculate scaling options!");
1.1 casties 484: return 1;
485: }
486:
1.2 casties 487: # convert
1.7 casties 488: my $cmd = "nice -10 $tiffloader \'$srcdir/$filename\' 2>/dev/null ";
489: if ($bitdepth == 1) {
490: # antialiasing bilevel images
491: $cmd .= "| nice -10 $quantizer 2 2 2>/dev/null ";
492: }
493: $cmd .= "| nice -10 $scaler $scaleopt 2>/dev/null | nice -10 $jpegwriter --quality $jpeg_quality > '$destdir/$newfn' 2>/dev/null";
494: logger('DEBUG', "$cmd");
1.2 casties 495: return 0 if ($simulate);
1.7 casties 496: if (system($cmd) != 0) {
1.2 casties 497: logger('ERROR', "error converting '$srcdir/$filename'!");
1.7 casties 498: if (! -s "$destdir/$newfn") {
499: # file broken (size 0)
500: logger('ERROR', "created file '$destdir/$newfn' broken -- will be removed!");
501: unlink "$destdir/$newfn";
502: }
1.2 casties 503: return 1;
504: }
505:
506: # change permissions
507: chmod $file_perm, "$destdir/$newfn" or
508: logger('WARNING', "unable to set permission on '$destdir/$newfn'");
509:
510: return 0;
511: }
512:
513:
514:
515: #
516: # $error = scale_tiff_png(\$args);
517: #
518: # scale TIFF images to PNG using netpbm tools
519: #
520: # args needed: $srcdir, $filename, $destdir,
1.7 casties 521: # $scale_w, $scale_h, $scale_rel, $picwidth, $picheight
1.2 casties 522: #
523: sub scale_tiff_png {
524: my ($args) = @_;
525:
526: my $srcdir = $$args{'srcdir'};
527: my $filename = $$args{'filename'};
528: my $destdir = $$args{'destdir'};
529: my $bitdepth = $$args{'bitdepth'};
1.7 casties 530: my $scale_w = $$args{'scale_w'};
531: my $scale_h = $$args{'scale_h'};
1.2 casties 532: my $scale_rel = $$args{'scale_rel'};
533: my $scaleopt;
534:
1.7 casties 535: # convert tif -> png
1.2 casties 536: my ($basename, $fileext) = splitfn($filename);
537: my $newfn = $basename . ".png";
538: logger('INFO', "Convert(tiff3): $filename -> $newfn");
539:
1.7 casties 540: $scaleopt = scalefactor($args);
1.2 casties 541:
542: if (!$scaleopt) {
543: logger('ERROR', "unable to calculate scaling options!");
1.1 casties 544: return 1;
545: }
546:
1.2 casties 547: # convert
548: my $cmd = "nice -10 $tiffloader \'$srcdir/$filename\' 2>/dev/null ";
549: if ($bitdepth == 1) {
550: # antialiasing bilevel images
551: $cmd .= "| nice -10 $quantizer 2 2 2>/dev/null ";
552: }
553: $cmd .= "| nice -10 $scaler $scaleopt 2>/dev/null | nice -10 $pngwriter > '$destdir/$newfn' 2>/dev/null";
554: logger('DEBUG', "$cmd");
555: return 0 if ($simulate);
556: if (system($cmd) != 0) {
557: logger('ERROR', "error converting '$srcdir/$filename'!");
1.7 casties 558: if (! -s "$destdir/$newfn") {
559: # file broken (size 0)
560: logger('ERROR', "created file '$destdir/$newfn' broken -- will be removed!");
561: unlink "$destdir/$newfn";
562: }
1.2 casties 563: return 1;
564: }
565:
566: # change permissions
567: chmod $file_perm, "$destdir/$newfn" or
568: logger('WARNING', "unable to set permission on '$destdir/$newfn'");
569:
570: return 0;
571: }
572:
573:
574: #
575: # $error = convert_file($srcdir, $filename, $destdir);
576: #
577: # convert file
578: #
579: sub convert_file {
1.9 casties 580: my($srcdir, $filename, $destdir, $filelist) = @_;
1.2 casties 581: my $filebase;
582: my $fileext;
583: my $newfn;
584: my $pictype;
585: my $picwidth;
586: my $picheight;
587: my $bitdepth;
588: my $error = 0;
589:
590: logger('DEBUG', "convert_file ($srcdir, $filename, $destdir)");
591:
592: if (not (( -f "$srcdir/$filename") && (-r _))) {
593: logger('ERROR', "unable to read file '$srcdir/$filename'");
594: return 1;
595: }
596:
597: # get base name and extension
1.9 casties 598: ($filebase, $fileext) = splitfn($filename);
1.2 casties 599:
1.1 casties 600: #
1.2 casties 601: # quick check if target image exists
1.1 casties 602: #
1.2 casties 603: $pictype = quickident("$srcdir/$filename");
604: if ($pictype) {
1.6 casties 605: if ($pictype eq "RAW") {
606: logger('DEBUG', "skipping raw file '$srcdir/$filename'");
607: return 0;
608: }
1.2 casties 609: my $newext = $target_ext_type{$pictype};
610: if ($newext) {
611: $newfn = $filebase . ".$newext";
1.9 casties 612: logger('DEBUG', "adding $destdir/$newfn'");
613: $$filelist{"$destdir/$newfn"} = $filename;
1.2 casties 614: # check if file exists
615: if (-f "$destdir/$newfn") {
616: logger('DEBUG', "CONV file exists: $newfn");
617: if (! $overwrite) {
1.7 casties 618: # compare age with source file
619: if (-M "$destdir/$newfn" > -M "$srcdir/$filename") {
620: logger('DEBUG', "CONV file is older: $newfn");
621: } else {
622: logger('INFO', "File already converted: $newfn");
623: return 0;
624: }
1.2 casties 625: }
1.1 casties 626: }
1.2 casties 627: } else {
628: logger('DEBUG', "target extension for $pictype unknown!");
1.1 casties 629: }
1.2 casties 630: } else {
631: # quick ident failed -- do it slowly
632: ($pictype, $picwidth, $picheight, $bitdepth) = identify("$srcdir/$filename");
633: if ((! $pictype)||($picwidth == 0)||($picheight == 0)) {
634: logger('WARNING', "unknown file type '$srcdir/$filename'");
1.1 casties 635: return 0;
636: }
637: }
638:
1.2 casties 639: # collect arguments for the conversion
640: my %args;
641: $args{'srcdir'} = $srcdir;
642: $args{'destdir'} = $destdir;
643: $args{'filename'} = $filename;
644: $args{'pictype'} = $pictype;
645: $args{'picwidth'} = $picwidth;
646: $args{'picheight'} = $picheight;
647: $args{'bitdepth'} = $bitdepth;
648: $args{'srcdir'} = $srcdir;
1.7 casties 649: $args{'scale_w'} = $scale_w;
650: $args{'scale_h'} = $scale_h;
1.2 casties 651: $args{'scale_rel'} = $scale_relative;
652:
653: # decide conversion based on image type and encoding preferences
654: if ($pictype eq 'JPEG') {
655: $args{'jpeg_qual'} = $jpeg_quality;
656: #default encoder
657: $error = scale_jpeg(\%args);
658: } elsif ($pictype eq 'TIFF') {
659: if ($use_encoder) {
660: # use specific encoder
661: if ($use_encoder eq 'tiff_jpeg') {
662: $error = scale_tiff_jpeg(\%args);
663: } elsif ($use_encoder eq 'tiff_jpeg2') {
664: $error = scale_tiff_jpeg2(\%args);
665: } elsif ($use_encoder eq 'tiff_png') {
666: $error = scale_tiff_png(\%args);
667: }
668: } else {
669: # default
670: $error = scale_tiff_jpeg(\%args);
671: }
672: } else {
673: logger('WARNING', "unknown file type: $pictype ($srcdir/$filename)");
674: }
675: return $error;
676: }
1.1 casties 677:
678:
679: #
680: # walk_convert_dir($dirname)
681: #
682: # Descend recursively through $dirname and work on all files
683: #
684: sub walk_convert_dir {
1.9 casties 685: my($srcdir, $workdir, $destdir, $filelist) = @_;
1.1 casties 686: my $errcnt = 0;
687: my $newfn;
688:
1.2 casties 689: opendir WORKDIR, "$srcdir/$workdir" or do {
690: logger('ERROR', "Unable to open directory $srcdir/$workdir!");
1.1 casties 691: return 0;
692: };
693:
694: my @dirlist = readdir(WORKDIR);
695:
696: closedir WORKDIR;
697:
1.9 casties 698: # check all directories first
1.1 casties 699: if ($do_descend) {
700: foreach (sort @dirlist) {
1.9 casties 701: # skip dot-directories
1.10 ! casties 702: next if (/^\..*$/);
1.9 casties 703: # skip junk directories
1.2 casties 704: next if ($junk_files{$_});
1.9 casties 705: # recurse through the rest
1.2 casties 706: if (-d "$srcdir/$workdir/$_") {
1.9 casties 707: walk_convert_dir($srcdir, "$workdir/$_", $destdir, $filelist);
1.1 casties 708: }
709: }
710: }
711:
1.2 casties 712: logger('INFO', "Working on $workdir");
713: logger('INFO', "Reading from $srcdir/$workdir.");
714: logger('INFO', "Writing to $destdir/$workdir");
1.1 casties 715:
1.2 casties 716: # create destination directory
1.1 casties 717: if (not ($simulate)) {
1.2 casties 718: mmkdir("$destdir/$workdir") or do {
719: logger("ERROR", "unable to create directory '$destdir/$workdir'");
1.1 casties 720: $errcnt++;
721: return 0;
722: };
723: }
1.2 casties 724:
1.9 casties 725: # check all files in this directory
1.1 casties 726: foreach (sort @dirlist) {
1.9 casties 727: # skip dot-files
728: next if (/^[.]+.*$/);
729: # try to convert the rest
1.2 casties 730: if (-f "$srcdir/$workdir/$_") {
1.9 casties 731: $errcnt += convert_file("$srcdir/$workdir", "$_", "$destdir/$workdir", $filelist);
1.1 casties 732: }
733: }
734:
735: if ($errcnt) {
1.2 casties 736: logger('INFO', "There were $errcnt errors converting '$workdir'!");
1.1 casties 737: } else {
1.2 casties 738: logger('INFO', "Finished converting $workdir!");
1.1 casties 739: }
740:
741: return 1;
742: }
743:
744:
745: #
746: # convert_dir($from_dir)
747: #
748: # Convert directory "from_dir" and its subdirectories
749: #
750: sub convert_dir {
1.2 casties 751: my ($srcdir, $workdir, $destdir) = @_;
1.9 casties 752: my %files = ();
1.1 casties 753:
1.2 casties 754: logger('INFO', "** Converting Scans **");
1.7 casties 755:
756: if (-d "$srcdir/$workdir") {
757: # it's a dirrectory
758: logger('INFO', "Starting in directory '$srcdir/$workdir'");
1.9 casties 759: walk_convert_dir($srcdir, $workdir, $destdir, \%files);
760: if ($synchronise) {
761: logger('INFO', "Removing unmatched files in '$destdir/$workdir'");
762: remove_unmatched_files("$destdir/$workdir", \%files);
763: }
1.7 casties 764: # touch source directory so digilib rescans the thumbnails
765: #logger('DEBUG', "/usr/bin/touch $source_base_dirs[0]/$workdir");
766: system("/usr/bin/touch '$srcdir/$workdir'");
767: } elsif (-f _) {
768: # it's a file
769: logger('INFO', "Converting file '$srcdir/$workdir'");
770: convert_file($srcdir, $workdir, $destdir);
771: # touch source parent directory so digilib rescans the thumbnails
772: my $pdir = "$srcdir/$workdir";
773: # chop off after the last slash
774: $pdir =~ s/\/[^\/]+$/\//;
775: system("/usr/bin/touch '$pdir'");
776: }
1.1 casties 777:
1.2 casties 778: logger('DONE', "** Finished converting scans **");
1.1 casties 779: return 1;
780: }
781:
782:
783:
1.9 casties 784: #
785: # remove_unmatched_files($basedir, \%files)
786: #
787: # removes all files from $basedir and its subdirectories that are not
788: # in %files
789: #
790: sub remove_unmatched_files {
791: my ($basedir, $files) = @_;
792: my $cnt = 0;
793:
794: if (! opendir DIR, $basedir) {
795: logger('ERROR', "directory $basedir doesn't exist (in remove_unmatched_files)");
796: return 0;
797: }
798: my @dirfiles = readdir DIR;
799: foreach my $fn (@dirfiles) {
800: # ignore names starting with a dot
801: next if ($fn =~ /^\./);
802: # ignore other silly files
803: next if ($junk_files{$fn});
804:
805: $cnt++;
806: my $f = "$basedir/$fn";
807: #print "fs_file: \"$f\"\n";
808: if (-f $f) {
809: #print " is file\n";
810: logger('DEBUG', "checking '$f'");
811: if (not exists($$files{$f})) {
812: logger('DEBUG', "removing orphaned file $f");
813: unlink $f;
814: }
815: } elsif (-d _) {
816: # recurse into directory
817: $cnt += remove_unmatched_files($f, $files);
818: # delete if its empty
819: rmdir $f;
820: }
821: }
822: return $cnt;
823: }
1.1 casties 824:
825:
826:
827: ###############################################################
828: ## Main
829:
1.2 casties 830: if ($#ARGV < 3) {
1.1 casties 831: print "Scale-O-Mat $version\n";
1.2 casties 832: print " use: scaleomat.pl -src=src-base -dest=dest-base -dir=workdir [...]\n";
833: print " reads from scr-base/workdir and writes to dest-base/workdir\n";
1.7 casties 834: print " -scaleto=destination size (S or WxH)\n";
1.2 casties 835: print " -scaleby=magnification factor.\n";
836: print " -jpegqual=JPEG quality (0-100)\n";
1.9 casties 837: print " -replace=yes replaces existing files (default=update).\n";
838: print " -sync=yes delete unmatched file in destination (default=ignore).\n";
1.2 casties 839: print " -encoder=tiff_png|tiff_jpeg|tiff_jpeg2\n";
1.1 casties 840: exit 1;
841: }
842:
843: # test software installation
1.2 casties 844: checksoft();
845:
846: # read command line parameters
847: my $args = parseargs();
848:
849: # source dir
1.4 casties 850: my $srcdir = cleanpath($$args{'src'}, 1);
1.1 casties 851:
1.2 casties 852: # destination dir
1.4 casties 853: my $destdir = cleanpath($$args{'dest'}, 1);
1.2 casties 854:
855: # working dir
1.4 casties 856: my $workdir = cleanpath($$args{'dir'});
1.2 casties 857:
858: # destination size
859: if ($$args{'scaleby'}) {
860: $scale_relative = 1;
1.7 casties 861: $scale_w = $$args{'scaleby'};
862: logger('INFO', "Scaling relative by factor $scale_w");
1.2 casties 863: }
864: if ($$args{'scaleto'}) {
865: $scale_relative = 0;
1.7 casties 866: if ($$args{'scaleto'} =~ /(\d+)x(\d+)/) {
867: $scale_w = $1;
868: $scale_h = $2;
869: } else {
870: $scale_w = $$args{'scaleto'};
871: $scale_h = $$args{'scaleto'};
872: }
873: logger('INFO', "Scaling absolute to size $scale_w x $scale_h");
1.2 casties 874: }
875:
876: # JPEG quality
877: if ($$args{'jpegqual'}) {
878: logger('INFO', "JPEG quality set to '$$args{'jpegqual'}'!");
879: $jpeg_quality = $$args{'jpegqual'};
880: }
881:
882: # force encoder
883: if ($$args{'encoder'}) {
884: logger('INFO', "Using encoder '$$args{'encoder'}'!");
885: $use_encoder = $$args{'encoder'};
1.1 casties 886: }
887:
1.2 casties 888: # Overwrite
889: if ($$args{'replace'}) {
890: logger('INFO', "Set to overwrite existing files!");
891: $overwrite = 1;
1.9 casties 892: }
893:
894: # Synchronise
895: if ($$args{'sync'}) {
896: logger('INFO', "Set to delete unmatched files!");
897: $synchronise = 1;
1.1 casties 898: }
899:
1.2 casties 900: # debug
901: if ($$args{'debug'}) {
902: logger('INFO', "Set debug level to $$args{'debug'}!");
903: $debug = $$args{'debug'};
1.1 casties 904: }
905:
1.2 casties 906: # simulate
907: if ($$args{'simulate'}) {
908: logger('INFO', "Set to simulate operation only ($$args{'simulate'})!");
909: $simulate = $$args{'simulate'};
1.1 casties 910: }
1.2 casties 911:
912: convert_dir($srcdir, $workdir, $destdir);
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvs/cvsweb/icons/back.gif){kind=icon}
Return to scaleomat.pl CVS log ![[TXT]](/cvs/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvs/cvsweb/icons/dir.gif){kind=icon}
Up to [Repository] / scaleomat