#!/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);
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>