1: #!/usr/bin/perl
2:
3: $| = 1; # unblock IO
4:
5: $version = "V0.7 (ROC 23.12.2003)";
6:
7: $debug = 0;
8: $simulate = 0;
9:
10: $do_descend = 1;
11:
12: @source_base_dirs = ("/docuserver/images");
13: $dest_base_dir = "/docuserver/scaled/small";
14: $dir_perm = 0775;
15: $file_perm = 0664;
16:
17: umask 000; # to make shure we can actually use these perms
18:
19: $dont_overwrite = 1; # don't overwrite already converted files
20:
21: @imgfile_ext = ("tif", "tiff", "gif", "jpg", "png");
22:
23: $target_size = 2048; # pixel of longest side
24: $scale_relative = 0; # scale by relative factor instead of destination size
25: $jpeg_quality = 75; # default JPEG compression quality
26:
27: ##########################################################################
28: # subroutines
29: #
30:
31: #
32: # checksoft()
33: #
34: # returns if all necessary external programs are installed
35: #
36: sub checksoft {
37:
38: my @softdirs = ("/usr/X11R6/bin", "/usr/bin", "/usr/local/bin");
39:
40: $identifier = findfile(\@softdirs, "identify")
41: or die("ABORT: neccessary external program not found: identify");
42: $jpegloader = findfile(\@softdirs, "jpegtopnm")
43: or die("ABORT: neccessary external program not found: jpegtopnm");
44: $tiffloader = findfile(\@softdirs, "tifftopnm")
45: or die("ABORT: neccessary external program not found: tifftopnm");
46: $quantizer = findfile(\@softdirs, "pbmtopgm")
47: or die("ABORT: neccessary external program not found: pbmtopgm");
48: $scaler = findfile(\@softdirs, "pnmscale")
49: or die("ABORT: neccessary external program not found: pnmscale");
50: $jpegwriter = findfile(\@softdirs, "ppmtojpeg")
51: or die("ABORT: neccessary external program not found: ppmtojpeg");
52: $pngwriter = findfile(\@softdirs, "pnmtopng")
53: or die("ABORT: neccessary external program not found: pnmtopng");
54: $converter = findfile(\@softdirs, "convert")
55: or die("ABORT: neccessary external program not found: convert");
56:
57: }
58:
59:
60:
61: #
62: # dprint($message)
63: #
64: # print if $debug = 1
65: #
66: sub dprint {
67: my ($msg) = @_;
68:
69: if ($debug) {
70: print "$msg";
71: }
72: }
73:
74:
75:
76: #
77: # findir(\@basedirs, $subdir)
78: #
79: # check directories in @basedirs+$subdir and return the first existing basedir
80: #
81: sub findir {
82: my($dirlist, $subdir) = @_;
83:
84: foreach my $dir (@$dirlist) {
85: if (-d "$dir/$subdir") {
86: return "$dir";
87: }
88: }
89: return;
90: }
91:
92: #
93: # findfile(\@basedirs, $filename)
94: #
95: # check @basedirs+$filename and return the first existing file
96: #
97: sub findfile {
98: my($dirlist, $fn) = @_;
99:
100: foreach my $dir (@$dirlist) {
101: if (-f "$dir/$fn") {
102: return "$dir/$fn";
103: }
104: }
105: return;
106: }
107:
108:
109: #
110: # mmkdir($dirname)
111: #
112: # create directory recursively and check permissions
113: #
114: sub mmkdir {
115: my($dirname) = @_;
116: my $newdir;
117:
118: # does the directory already exist?
119: if (-d $dir) {
120: chmod $dir_perm, $dir or do {
121: print "ERROR: unable to change permission on $dir!\n";
122: return 0;
123: };
124: return 1;
125: }
126: # split directory name by levels
127: my @dirlist = split /\//, $dirname;
128: my @newlist = ();
129: my $dir = join("/", @dirlist);
130: # test backwards which directories exist
131: while (not -d $dir) {
132: # move missing elements from the end of @dirlist to @newlist
133: unshift @newlist, pop @dirlist;
134: $dir = join("/", @dirlist);
135: }
136: # create missing directories level by level
137: foreach $newdir (@newlist) {
138: push @dirlist, $newdir;
139: $dir = join("/", @dirlist);
140: mkdir "$dir", $dir_perm or do {
141: print "ERROR: unable to create $dir!\n";
142: return 0;
143: }
144: }
145: return 1;
146: }
147:
148: #
149: # dir_ok($dirname)
150: #
151: # check directory name against evil
152: #
153: sub dir_ok {
154: my($dirname) = @_;
155:
156: if ($dirname eq "") {
157: print "ERROR: DIR mustn't be empty!\n";
158: return 0;
159: }
160: if ($dirname =~ /\.\./) {
161: print "ERROR: DIR mustn't backref!\n";
162: return 0;
163: }
164: if ($dirname =~ /[|<>]+/) {
165: print "ERROR: DIR mustn't be special!\n";
166: return 0;
167: }
168: return 1;
169: }
170:
171:
172: #
173: # convert_file($filename)
174: #
175: # convert file
176: #
177: sub convert_file {
178: my($basedir, $filename) = @_;
179: my $newfn;
180: my $pictype;
181: my $picwidth;
182: my $picheight;
183: my $scaleopt = 0.3;
184:
185: if (not (( -f "$basedir/$filename") && (-r _))) {
186: print "ERROR: unable to read file '$basedir/$filename'\n;";
187: return 0;
188: }
189:
190: #
191: # run ident first to get image type and dimensions
192: # calculate scaling factor based on destination size or factor
193: #
194: if (open(IDENT, "nice -10 $identifier -ping -format '%w %h %m\n' '$basedir/$filename' 2>/dev/null|")) {
195: my @id = <IDENT>;
196: my $picinfo = $id[0];
197: close IDENT;
198: chomp $picinfo;
199: dprint "INFO: PIC is $picinfo\n";
200: if ($picinfo =~ /^(\d+) (\d+) (\w+)$/) {
201: $picwidth = $1;
202: $picheight = $2;
203: $pictype = $3;
204: if ($scale_relative) {
205: $scaleopt = $target_size;
206: } else {
207: if ($picheight > $picwidth) {
208: $scaleopt = $target_size / $picheight;
209: dprint "INFO: PIC is portrait\n";
210: } else {
211: $scaleopt = $target_size / $picwidth;
212: dprint "INFO: PIC is landscape\n";
213: }
214: if ($scaleopt >= 1) {
215: $scaleopt = 1;
216: dprint "INFO: PIC is already smaller\n";
217: }
218: }
219: }
220: }
221:
222: #
223: # scale JPEG images to JPEG using netpbm tools
224: #
225: if ($pictype eq 'JPEG') {
226: # convert jpg -> jpg
227: $newfn = $filename;
228: $newfn =~ s/\.\w+$/.jpg/;
229: if (-f "$dest_base_dir/$newfn") {
230: dprint "INFO CONV file exists: $newfn\n";
231: if ($dont_overwrite) {
232: print "INFO: File already converted: $newfn\n";
233: return 1;
234: }
235: }
236: print "INFO: Convert(jpg): $filename -> $newfn\n";
237: return 1 if ($simulate);
238: dprint("nice -10 $jpegloader '$basedir/$filename' 2>/dev/null | nice -10 $scaler $scaleopt 2>/dev/null | nice -10 $jpegwriter > '$dest_base_dir/$newfn' 2>/dev/null\n");
239: if (system("nice -10 $jpegloader '$basedir/$filename' 2>/dev/null | nice -10 $scaler $scaleopt 2>/dev/null | nice -10 $jpegwriter > '$dest_base_dir/$newfn' 2>/dev/null") != 0) {
240: return 0;
241: }
242: chmod $file_perm, "$dest_base_dir/$newfn" or
243: print "WARNING: unable to set permission on '$dest_base_dir/$newfn'\n";
244: return 1;
245: }
246:
247: #
248: # scale TIFF images to JPEG using convert
249: # (slower but netpbm doesn't always work)
250: #
251: if ($pictype eq 'TIFF') {
252: # convert tif -> jpg
253: $newfn = $filename;
254: $newfn =~ s/\.\w+$/.jpg/;
255: if (-f "$dest_base_dir/$newfn") {
256: dprint "INFO: CONV file exists: $newfn\n";
257: if ($dont_overwrite) {
258: print "INFO: File already converted: $newfn\n";
259: return 1;
260: }
261: }
262: print "INFO: Convert(tif): $filename -> $newfn\n";
263: if ($scale_relative) {
264: my $per_scale = 100 * $scaleopt;
265: dprint("nice -10 $converter -quality $jpeg_quality -scale $per_scale\% $basedir/$filename $dest_base_dir/$newfn 2>/dev/null\n");
266: return 1 if ($simulate);
267: if (system("nice -10 $converter -quality $jpeg_quality -scale $per_scale\% '$basedir/$filename' '$dest_base_dir/$newfn' 2>/dev/null\n") != 0) {
268: return 0;
269: }
270: } else {
271: dprint("nice -10 $converter -quality $jpeg_quality -scale ${target_size}x${target_size} $basedir/$filename $dest_base_dir/$newfn 2>/dev/null\n");
272: return 1 if ($simulate);
273: if (system("nice -10 $converter -quality $jpeg_quality -scale ${target_size}x${target_size} '$basedir/$filename' '$dest_base_dir/$newfn' 2>/dev/null\n") != 0) {
274: return 0;
275: }
276: }
277: chmod $file_perm, "$dest_base_dir/$newfn" or
278: print "WARNING: unable to set permission on '$newfn'\n;";
279: return 1;
280: }
281:
282: #
283: # convert TIFF to PNG using netpbm tools (not used any more)
284: #
285: if ($pictype eq 'TIFF_old') {
286: # convert tif -> png
287: $newfn = $filename;
288: $newfn =~ s/\.\w+$/.png/;
289: if (-f "$dest_base_dir/$newfn") {
290: dprint "INFO: CONV file exists: $newfn\n";
291: if ($dont_overwrite) {
292: print "INFO: File already converted: $newfn\n";
293: return 1;
294: }
295: }
296: print "INFO: Convert(tif): $filename -> $newfn\n";
297: return 1 if ($simulate);
298: dprint("nice -10 $tiffloader $basedir/$filename 2>/dev/null | nice -10 $quantizer 2 2 2>/dev/null | nice -10 $scaler $scaleopt 2>/dev/null | nice -10 $pngwriter > $dest_base_dir/$newfn 2>/dev/null\n");
299: if (system("nice -10 $tiffloader $basedir/$filename 2>/dev/null | nice -10 $quantizer 2 2 2>/dev/null | nice -10 $scaler $scaleopt 2>/dev/null | nice -10 $pngwriter > $dest_base_dir/$newfn 2>/dev/null") != 0) {
300: return 0;
301: }
302: chmod $file_perm, "$dest_base_dir/$newfn" or
303: print "WARNING: unable to set permission on '$newfn'\n;";
304: return 1;
305: }
306:
307: print "WARNING: unknown file type: '$basedir/$filename'\n;";
308: return 0;
309: }
310:
311:
312: #
313: # walk_convert_dir($dirname)
314: #
315: # Descend recursively through $dirname and work on all files
316: #
317: sub walk_convert_dir {
318: my($workdir) = @_;
319: my $errcnt = 0;
320: my $newfn;
321:
322: my $basedir = findir(\@source_base_dirs, $workdir);
323:
324: opendir WORKDIR, "$basedir/$workdir" or do {
325: print "ERROR: Unable to open directory $basedir/$workdir!\n";
326: return 0;
327: };
328:
329: my @dirlist = readdir(WORKDIR);
330:
331: closedir WORKDIR;
332:
333: if ($do_descend) {
334: foreach (sort @dirlist) {
335: if (/^[.]+$/) {
336: next;
337: }
338: if (-d "$basedir/$workdir/$_") {
339: walk_convert_dir("$workdir/$_");
340: }
341: }
342: }
343:
344: print "INFO: Working on $workdir\n";
345: print "INFO: Reading from $basedir.\n";
346: print "INFO: Writing to $dest_base_dir\n";
347:
348: if (not ($simulate)) {
349: mmkdir("$dest_base_dir/$workdir") or do {
350: print "ERROR: unable to create directory '$dest_base_dir/$workdir'\n;";
351: $errcnt++;
352: return 0;
353: };
354: if ($dont_overwrite == 0) {
355: foreach (@imgfile_ext) {
356: system("rm -f $dest_base_dir/$workdir/*.$_");
357: }
358: }
359: }
360:
361: foreach (sort @dirlist) {
362: if (/^[.]+.*$/) {
363: next;
364: }
365: if (-f "$basedir/$workdir/$_") {
366: if (convert_file($basedir, "$workdir/$_") == 0) {
367: $errcnt++;
368: }
369: }
370: }
371:
372: if ($errcnt) {
373: print "INFO: There were errors converting $workdir!\n";
374: } else {
375: print "INFO: Finished converting $workdir!\n";
376: }
377:
378: return 1;
379: }
380:
381:
382: #
383: # convert_dir($from_dir)
384: #
385: # Convert directory "from_dir" and its subdirectories
386: #
387: sub convert_dir {
388: my ($workdir) = @_;
389:
390: print "INFO: ** Converting Scans **\n";
391: print "INFO: Starting in directory '$workdir'\n";
392:
393: dir_ok($workdir) or die("ABORT: Illegal directory name '$workdir'!\n");
394:
395: walk_convert_dir($workdir);
396:
397: # touch source directory so digilib rescans the thumbnails
398: #print "DEBUG:/usr/bin/touch $source_base_dirs[0]/$workdir\n";
399: system("/usr/bin/touch $source_base_dirs[0]/$workdir");
400:
401: print "DONE: ** Finished converting scans **\n";
402: return 1;
403: }
404:
405:
406:
407:
408:
409:
410: ###############################################################
411: ## Main
412:
413: if ($#ARGV < 0) {
414: print "Scale-O-Mat $version\n";
415: print " use: scaleomat.pl hires-dir dest-base size [quality] [--replace]\n";
416: print " - if hires-dir starts with '/' then it's absolute.\n";
417: print " - if size starts with 'x' then it's magnification factor.\n";
418: print " - quality is JPEG quality (0-100)\n";
419: print " - --replace replaces existing files (default=skip).\n";
420: exit 1;
421: }
422:
423: # test software installation
424: checksoft;
425:
426: # parameter 1 is destination dir
427: if ($#ARGV > 0) {
428: $dest_base_dir = $ARGV[1];
429: }
430:
431: # parameter 2 is destination size (or factor when starting with "x")
432: if ($#ARGV > 1) {
433: if ($ARGV[2] =~ /^x([\d.]+)/) {
434: $scale_relative = 1;
435: $target_size = $1;
436: print "INFO: scaling relative by factor $target_size\n";
437: } else {
438: $scale_relative = 0;
439: $target_size = $ARGV[2];
440: print "INFO: scaling absolute to size $target_size\n";
441: }
442: }
443:
444: # optional parameters are JPEG quality or --replace
445: if ($#ARGV > 2) {
446: for ($i = 3; $i <= $#ARGV; $i++) {
447: $s = $ARGV[$i];
448: if ($s eq "--replace") {
449: print "INFO: set to overwrite existing files!\n";
450: $dont_overwrite = 0;
451: } else {
452: print "INFO: JPEG quality set to '$s'!\n";
453: $jpeg_quality = $s;
454: }
455: }
456: }
457:
458: # convert all files in the directory
459: my $srcdir = $ARGV[0];
460: if ($srcdir =~ /^\//) {
461: # if source dir starts with / then ist's absolute
462: $source_base_dirs[0] = "/";
463: }
464: convert_dir($srcdir);
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