forked from MapServer/MapServer
-
Notifications
You must be signed in to change notification settings - Fork 2
PerlMapScriptExamples35ex6
Thomas Bonfort edited this page Apr 6, 2012
·
2 revisions
#!perl
#!/usr/bin/perl -w
#
# Copyright (C) 2002, Lowell Filak.
# You may distribute this file under the terms of the Artistic
# License.
#
# Given a directory containing tiff(s) and tfw(s), the original pixel size,
# the destination directory for resized & recolored tiff(s), & the new
# pixel size this routine will resize & recolor the tiff(s) and write
# new wld files to match.
#
# Required modules are Getopt (normally included with Perl).
# A successful install of ImageMagick
# is required. The routine does NOT utilize the ImageMagick perl module
# at this time. The routine also assumes a *n*x system, please change
# command lines accordingly.
# Please download resize_orthos.tar.gz also, and:
# tar -xf resize_orthos.tar.gz --ungzip
#
# Suggested run line = ./resize_orthos.pl -orig=orthos -osize=8 -out=new -nsize=10
################################################################################
use Getopt::Long;
#
# Subroutine for bailout on error.
sub bailout {
print "*** HELP! I've Fallen & I Can't Get Up!\n";
#
# Throw marker in output message.
print "*********************************************************************\n";
#
# Print date & time.
system("date");
exit 0;
} # end subroutine
################################################################################
#
# Main routine.
#
# Grab input values.
&GetOptions('orig=s' => \$orthos_orig, 'osize=s' => \$orig_size, 'out=s' => \$orthos_out, 'nsize=s' => \$new_size);
#
# Check the input values.
if ( (!$orthos_orig) || (!$orig_size) || (!$orthos_out) || (!$new_size) ) {
print "Syntax: resize.pl -orig=[original_dir] -osize=[original_pixel_size] -out=[out_dir] -nsize=[new_pixel_size]\n";
bailout;
}
#
# Declare variables.
# Note: Please change this to your path to convert (whereis convert).
$convert = '/usr/X11R6/bin/convert';
#
# Make sure out directory exists.
#
# Split the path apart.
@mpath = split('/',$orthos_out);
#
# How many members to the path.
$mpathcnt = scalar @mpath;
#
# Is the first member blank, ie. ' '/home/global .
# Basically was an absolute or relative path specified.
if (!$mpath[0]) {
#
# Start with 1.
$start = 1;
#
# Start path with /.
$cpath = '/';
}
else {
#
# Start with 0.
$start = 0;
#
# Start path with ''.
$cpath = '';
}
#
# End with total -1.
$mpathcnt = $mpathcnt - 1;
for $pathpart ($start .. $mpathcnt) {
#
# Set the create path.
$cpath = $cpath . $mpath[$pathpart];
if ( -e "$cpath" ) {
#
# Do nothing.
}
else {
#
# Create it.
@mkdirerror = system("mkdir $cpath");
if ( $mkdirerror[0] > 0 ) {
print "*** Mkdir $cpath Failed!\n";
bailout;
}
else {
#
# Fall through.
}
}
#
# For lack of a better term "Increment" path.
$cpath = $cpath.'/';
}
#
# Append the new size to the out dir to allow for multiple new sizes.
$orthos_out = $orthos_out . "/" . "$new_size";
#
# Print date & time just for information.
#@dateerror = system("date");
#
# Create the destination directory.
@mkdirerror = system("mkdir $orthos_out");
#
# We know the original pixel size is $orig_size so use that to determine
# the percentage of reduction for the new size.
# Notes: Try to keep this so the division comes out evenly. Uneven results
# can leave black lines between tiles. This may only work for flat
# projections.
my $percentage = $orig_size / $new_size * 100;
#
# Check the percentage.
if ( $percentage > 100 ) {
print "Argh! I have no idea what the output will look like if I resample smaller.\n";
bailout;
}
else {
#
# Fall through.
}
#
# Create a list of files to convert.
system("ls -1 $orthos_orig/*.tif > orthos.list");
#
# Read-in and loop through each ortho.
#
# Open the list.
open(ORTHOS, "<orthos.list");
#
# Loop.
while(<ORTHOS>) {
#
# Split the full path apart.
#
# Grab the line.
my $full_path = $_;
#
# Remove the newline.
$full_path =~ s/\n//;
#
# Split on the /.
my @full_path = split(/\//, $full_path);
#
# How many parts to the path.
my $path_length = scalar(@full_path);
#
# Bring the count down one to match array start of 0.
$path_length = $path_length - 1;
#
# File name is the last member of array.
my $file = $full_path[$path_length];
#
# Chop off file extension.
my @file = split(/\./, $file);
#
# Set world file name to just name without extension.
my $tfw = $file[0];
#
# Create temp & out file name.
my $tmp_out = "/tmp/" . $file;
my $file_out = $orthos_out . "/" . $file;
#
# See if tiff already exists.
if ( -e "$file_out") {
#
# Do nothing.
}
else {
#
# Convert the resized tif image into /tmp.
my $convert_line = $convert . " -geometry " . $percentage . "\%x" . $percentage . "\% " . $full_path . " " . $tmp_out;
#
# For debugging only.
print "$convert_line\n";
#
# run the resize convert statement.
@converterror = system("$convert_line");
#
# Convert the recolored tif image into $orthos_out.
# Note: This currently allows for 256 colors. It has been reported that
# this number must be smaller to allow for antialiased fonts. I
# have not experienced this directly but if it does create a
# problem change the 256 to a lower number.
$convert_line = $convert . " -colors 256 " . $tmp_out . " " . $file_out;
#
# For debugging only.
print "$convert_line\n";
#
# run the resize convert statement.
@converterror = system("$convert_line");
#
# Remove temporary resized file.
unlink $tmp_out;
}
#
# Create original & out world file names.
# Note: In this case the original images are tfw instead of world files.
my $tfw_in = $orthos_orig . "/" . $tfw . ".tfw";
my $tfw_out = $orthos_out . "/" . $tfw . ".wld";
#
# See if tfw already exists.
if ( -e "$tfw_out") {
#
# Do nothing.
}
else {
#
# Open the existing tfw for reading to create the new tfw.
#
# For debugging only.
#print "$tfw_in\n";
#
# Open it.
open(TFW, "<$tfw_in");
#
# Open new tfw for writing.
#
# For debugging only.
#print "$tfw_out\n";
#
# Open it.
open(TFWOUT, ">$tfw_out");
#
# Set a line counter.
my $linenum = 1;
#
# Loop through each line.
while(<TFW>) {
#
# Grab the line.
my $line = $_;
#
# Remove leading spaces.
$line =~ s/^\s+//;
#
# Remove newline, carriage return, or both.
$line =~ s/\015\012|\015|\012//g;
#
# For debugging only.
#print "$line\n";
#
# Is it line #1 or #4.
if ( $linenum == 1 ) {
#
# If so print the new pixel size (x).
print TFWOUT "$new_size\.000000\n";
}
elsif ( $linenum == 4 ) {
#
# If so print the new pixel size negative (y).
print TFWOUT "-$new_size\.000000\n";
}
else {
#
# Else just dump the existing line.
print TFWOUT "$line\n";
}
#
# Increment the line counter.
$linenum = $linenum + 1;
}
#
# Close the input and output world files.
close TFWOUT;
close TFW;
}
}
#
# Close the orthos list.
close ORTHOS;
#
# Remove the orthos list.
unlink "orthos.list";
back to PerlMapScrip