Return to scaleomat.pl CVS log

Up to [Repository] / scaleomat

Initial revision

#!/usr/bin/perl

$| = 1; # unblock IO

$version = "V0.7 (ROC 23.12.2003)";

$debug = 0;
$simulate = 0;

$do_descend = 1;

@source_base_dirs = ("/docuserver/images");
$dest_base_dir = "/docuserver/scaled/small";
$dir_perm = 0775;
$file_perm = 0664;

umask 000; # to make shure we can actually use these perms

$dont_overwrite = 1; # don't overwrite already converted files

@imgfile_ext = ("tif", "tiff", "gif", "jpg", "png");

$target_size = 2048; # pixel of longest side
$scale_relative = 0; # scale by relative factor instead of destination size
$jpeg_quality = 75; # default JPEG compression quality

##########################################################################
# subroutines
#

#
# checksoft()
#
# returns if all necessary external programs are installed
#
sub checksoft {

    my @softdirs = ("/usr/X11R6/bin", "/usr/bin", "/usr/local/bin");

    $identifier = findfile(\@softdirs, "identify")
	or die("ABORT: neccessary external program not found: identify");
    $jpegloader = findfile(\@softdirs, "jpegtopnm")
	or die("ABORT: neccessary external program not found: jpegtopnm");
    $tiffloader = findfile(\@softdirs, "tifftopnm")
	or die("ABORT: neccessary external program not found: tifftopnm");
    $quantizer = findfile(\@softdirs, "pbmtopgm")
	or die("ABORT: neccessary external program not found: pbmtopgm");
    $scaler = findfile(\@softdirs, "pnmscale")
	or die("ABORT: neccessary external program not found: pnmscale");
    $jpegwriter = findfile(\@softdirs, "ppmtojpeg")
	or die("ABORT: neccessary external program not found: ppmtojpeg");
    $pngwriter = findfile(\@softdirs, "pnmtopng")
	or die("ABORT: neccessary external program not found: pnmtopng");
    $converter = findfile(\@softdirs, "convert")
	or die("ABORT: neccessary external program not found: convert");

}



#
# dprint($message)
# 
# print if $debug = 1
#
sub dprint {
    my ($msg) = @_;

    if ($debug) {
	print "$msg";
    }
}



#
# findir(\@basedirs, $subdir)
#
# check directories in @basedirs+$subdir and return the first existing basedir
#
sub findir {
    my($dirlist, $subdir) = @_;

    foreach my $dir (@$dirlist) {
	if (-d "$dir/$subdir") {
	    return "$dir";
	}
    }
    return;
}

#
# findfile(\@basedirs, $filename)
#
# check @basedirs+$filename and return the first existing file
#
sub findfile {
    my($dirlist, $fn) = @_;

    foreach my $dir (@$dirlist) {
	if (-f "$dir/$fn") {
	    return "$dir/$fn";
	}
    }
    return;
}


#
# mmkdir($dirname)
#
# create directory recursively and check permissions
#
sub mmkdir {
    my($dirname) = @_;
    my $newdir;

    # does the directory already exist?
    if (-d $dir) {
	chmod $dir_perm, $dir or do {
	    print "ERROR: unable to change permission on $dir!\n";
	    return 0;
	};
	return 1;
    }
    # split directory name by levels
    my @dirlist = split /\//, $dirname;
    my @newlist = ();
    my $dir = join("/", @dirlist);
    # test backwards which directories exist
    while (not -d $dir) {
	# move missing elements from the end of @dirlist to @newlist
	unshift @newlist, pop @dirlist;
	$dir = join("/", @dirlist);
    }
    # create missing directories level by level
    foreach $newdir (@newlist) {
	push @dirlist, $newdir;
	$dir = join("/", @dirlist);
	mkdir "$dir", $dir_perm or do {
	    print "ERROR: unable to create $dir!\n";
	    return 0;
	}
    }
    return 1;
}

#
# dir_ok($dirname)
#
# check directory name against evil
#
sub dir_ok {
    my($dirname) = @_;

    if ($dirname eq "") {
	print "ERROR: DIR mustn't be empty!\n";
	return 0;
    }
    if ($dirname =~ /\.\./) {
	print "ERROR: DIR mustn't backref!\n";
	return 0;
    }
    if ($dirname =~ /[|<>]+/) {
	print "ERROR: DIR mustn't be special!\n";
	return 0;
    }
    return 1;
}


#
# convert_file($filename)
#
# convert file
#
sub convert_file {
    my($basedir, $filename) = @_;
    my $newfn;
    my $pictype;
    my $picwidth;
    my $picheight;
    my $scaleopt = 0.3;

    if (not (( -f "$basedir/$filename") && (-r _))) {
	print "ERROR: unable to read file '$basedir/$filename'\n;";
	return 0;
    }

    #
    # run ident first to get image type and dimensions
    # calculate scaling factor based on destination size or factor
    #
    if (open(IDENT, "nice -10 $identifier -ping -format '%w %h %m\n' '$basedir/$filename' 2>/dev/null|")) {
	my @id = <IDENT>;
	my $picinfo = $id[0];
	close IDENT;
	chomp $picinfo;
	dprint "INFO: PIC is $picinfo\n";
	if ($picinfo =~ /^(\d+) (\d+) (\w+)$/) {
	    $picwidth = $1;
	    $picheight = $2;
	    $pictype = $3;
	    if ($scale_relative) {
		$scaleopt = $target_size;
	    } else {
		if ($picheight > $picwidth) {
		    $scaleopt = $target_size / $picheight;
		    dprint "INFO: PIC is portrait\n";
		} else {
		    $scaleopt = $target_size / $picwidth;
		    dprint "INFO: PIC is landscape\n";
		}
		if ($scaleopt >= 1) {
		    $scaleopt = 1;
		    dprint "INFO: PIC is already smaller\n";
		}
	    }
	}
    }
    
    #
    # scale JPEG images to JPEG using netpbm tools
    #
    if ($pictype eq 'JPEG') {
	# convert jpg -> jpg
	$newfn = $filename;
	$newfn =~ s/\.\w+$/.jpg/;
	if (-f "$dest_base_dir/$newfn") {
	    dprint "INFO  CONV file exists: $newfn\n";
	    if ($dont_overwrite) {
		print "INFO:  File already converted: $newfn\n";
		return 1;
	    }
	}
	print "INFO: Convert(jpg): $filename -> $newfn\n";
	return 1 if ($simulate);
	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");
	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) {
	    return 0;
	}
	chmod $file_perm, "$dest_base_dir/$newfn" or
	    print "WARNING: unable to set permission on '$dest_base_dir/$newfn'\n";
	return 1;
    }

    #
    # scale TIFF images to JPEG using convert 
    # (slower but netpbm doesn't always work)
    #
    if ($pictype eq 'TIFF') {
	# convert tif -> jpg
	$newfn = $filename;
	$newfn =~ s/\.\w+$/.jpg/;
	if (-f "$dest_base_dir/$newfn") {
	    dprint "INFO:  CONV file exists: $newfn\n";
	    if ($dont_overwrite) {
		print "INFO:  File already converted: $newfn\n";
		return 1;
	    }
	}
	print "INFO: Convert(tif): $filename -> $newfn\n";
	if ($scale_relative) {
	    my $per_scale = 100 * $scaleopt;
	    dprint("nice -10 $converter -quality $jpeg_quality -scale $per_scale\% $basedir/$filename $dest_base_dir/$newfn 2>/dev/null\n");
	    return 1 if ($simulate);
	    if (system("nice -10 $converter -quality $jpeg_quality -scale $per_scale\% '$basedir/$filename' '$dest_base_dir/$newfn' 2>/dev/null\n") != 0) {
		return 0;
	    }
	} else {
	    dprint("nice -10 $converter -quality $jpeg_quality -scale ${target_size}x${target_size} $basedir/$filename $dest_base_dir/$newfn 2>/dev/null\n");
	    return 1 if ($simulate);
	    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) {
		return 0;
	    }
	}
	chmod $file_perm, "$dest_base_dir/$newfn" or
	    print "WARNING: unable to set permission on '$newfn'\n;";
	return 1;
    }

    #
    # convert TIFF to PNG using netpbm tools (not used any more)
    #
    if ($pictype eq 'TIFF_old') {
	# convert tif -> png
	$newfn = $filename;
	$newfn =~ s/\.\w+$/.png/;
	if (-f "$dest_base_dir/$newfn") {
	    dprint "INFO:  CONV file exists: $newfn\n";
	    if ($dont_overwrite) {
		print "INFO:  File already converted: $newfn\n";
		return 1;
	    }
	}
	print "INFO: Convert(tif): $filename -> $newfn\n";
	return 1 if ($simulate);
	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");
	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) {
	    return 0;
	}
	chmod $file_perm, "$dest_base_dir/$newfn" or
	    print "WARNING: unable to set permission on '$newfn'\n;";
	return 1;
    }

    print "WARNING: unknown file type: '$basedir/$filename'\n;";
    return 0;
}    


#
# walk_convert_dir($dirname)
#
# Descend recursively through $dirname and work on all files
#
sub walk_convert_dir {
    my($workdir) = @_;
    my $errcnt = 0;
    my $newfn;

    my $basedir = findir(\@source_base_dirs, $workdir);

    opendir WORKDIR, "$basedir/$workdir" or do {
	print "ERROR: Unable to open directory $basedir/$workdir!\n";
	return 0;
    };

    my @dirlist = readdir(WORKDIR);

    closedir WORKDIR;

    if ($do_descend) {
	foreach (sort @dirlist) {
	    if (/^[.]+$/) {
		next;
	    }
	    if (-d "$basedir/$workdir/$_") {
		walk_convert_dir("$workdir/$_");
	    }
	}
    }

    print "INFO:  Working on $workdir\n";
    print "INFO:    Reading from $basedir.\n";
    print "INFO:    Writing to $dest_base_dir\n";

    if (not ($simulate)) {
	mmkdir("$dest_base_dir/$workdir") or do {
	    print "ERROR: unable to create directory '$dest_base_dir/$workdir'\n;";
	    $errcnt++;
	    return 0;
	};
	if ($dont_overwrite == 0) {
	    foreach (@imgfile_ext) {
		system("rm -f $dest_base_dir/$workdir/*.$_");
	    }
	}
    }
 
    foreach (sort @dirlist) {
	if (/^[.]+.*$/) {
	    next;
	}
	if (-f "$basedir/$workdir/$_") {
	    if (convert_file($basedir, "$workdir/$_") == 0) {
		$errcnt++;
	    }
	}
    }

    if ($errcnt) {
	print "INFO:  There were errors converting $workdir!\n";
    } else {
	print "INFO:  Finished converting $workdir!\n";
    }

    return 1;
}


#
# convert_dir($from_dir)
#
# Convert directory "from_dir" and its subdirectories
#
sub convert_dir {
    my ($workdir) = @_;

    print "INFO: ** Converting Scans **\n";
    print "INFO: Starting in directory '$workdir'\n";
    
    dir_ok($workdir) or die("ABORT: Illegal directory name '$workdir'!\n");

    walk_convert_dir($workdir);

    # touch source directory so digilib rescans the thumbnails
    #print "DEBUG:/usr/bin/touch $source_base_dirs[0]/$workdir\n";
    system("/usr/bin/touch $source_base_dirs[0]/$workdir");

    print "DONE: ** Finished converting scans **\n";
    return 1;
}






###############################################################
## Main

if ($#ARGV < 0) {
    print "Scale-O-Mat $version\n";
    print "  use: scaleomat.pl hires-dir dest-base size [quality] [--replace]\n";
    print "    - if hires-dir starts with '/' then it's absolute.\n";
    print "    - if size starts with 'x' then it's magnification factor.\n";
    print "    - quality is JPEG quality (0-100)\n";
    print "    - --replace replaces existing files (default=skip).\n";
    exit 1;
}

# test software installation
checksoft;

# parameter 1 is destination dir
if ($#ARGV > 0) {
    $dest_base_dir = $ARGV[1];
}

# parameter 2 is destination size (or factor when starting with "x")
if ($#ARGV > 1) {
    if ($ARGV[2] =~ /^x([\d.]+)/) {
	$scale_relative = 1;
	$target_size = $1;
	print "INFO: scaling relative by factor $target_size\n";
    } else {
	$scale_relative = 0;
	$target_size = $ARGV[2];
	print "INFO: scaling absolute to size $target_size\n";
    }
}

# optional parameters are JPEG quality or --replace
if ($#ARGV > 2) {
    for ($i = 3; $i <= $#ARGV; $i++) {
	$s = $ARGV[$i];
	if ($s eq "--replace") {
	    print "INFO: set to overwrite existing files!\n";
	    $dont_overwrite = 0;
	} else {
	    print "INFO: JPEG quality set to '$s'!\n";
	    $jpeg_quality = $s;
	}
    }
}

# convert all files in the directory
my $srcdir = $ARGV[0];
if ($srcdir =~ /^\//) {
    # if source dir starts with / then ist's absolute
    $source_base_dirs[0] = "/";
}
convert_dir($srcdir);