Annotation of scaleomat/scaleomat.pl, revision 1.1
1.1 ! casties 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