#!/usr/local/bin/perl -w

my $version="0.12 (beta)";

#  Copyright (c) 1999-2000 by Axel Beckert <abe@deuxchevaux.org>
#
#  This program is free software; you can redistribute it and/or
#  modify it under the terms of the GNU General Public License
#  as published by the Free Software Foundation; either version 2
#  of the License, or (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
#
#  You can reach the author by snail-mail at the following address:
#  
#  Axel Beckert
#  Saarbrücker Straße 267a
#  66125 Saarbrücken, Germany

# ctm.pl creates Apache type maps for all files having the same prefix
# (including all but the suffix) as the as parameter given files.
#
# Example: 
# 
# Assume there exist the following files: head.gif, head.png,
# head.jpg, test.gif, test/test.gif, test/test.jpg, test/head.png
#
# Then 
#
#     ctm.pl head.gif test/test.jpg
#
# will create a two maps: 
#   * head.map for head.gif, head.png and head.jpg
#   * test/test.map for test/test.gif and test/test.jpg
#
# test/head.png and test.gif won't appear in any of the both type
# maps.


$|=1;

my $map_suffix="map";
my @use_suffixes=();
my @not_suffixes=();
my $help=0;
my $versionmode=0;
my $progname=$0;
$progname=~s!^.*/([^/]+)$!$1!;

foreach (@ARGV) {
    $help=1 if ($_ eq "--help");
    $versionmode=1 if ($_ eq "--version");
}

if (@ARGV==0 or $help==1) {
    print <<EOT;
ctm.pl version $version, Copyright (c) Axel Beckert
<abe\@deuxchevaux.org>

ctm.pl comes with ABSOLUTELY NO WARRANTY; This is free software, and
you are welcome to redistribute it under certain conditions; for
details see file COPYING.

Usage: $progname [-m map-suffix] [-M mime.types file] [-Q quality file] \\
       [-s suffixes to use] [-i suffixes not to use] file [file ...]

  -m map-suffix         Use map-suffix as suffix for map files. 
                        Default ist "map".

  -s suffix,suffix,...  Create only maps for files with these suffixes.
                        Default value are all suffixes which appear
                        with one of the prefixes of the given files.

  -i suffix,suffix,...  Create no maps for files with these suffixes.

  -M mime.types file    Tell me where to find your mime.types file, if
                        I can\'t find it in the standard
                        locations. You may also set \$MIMETYPES to the
                        appropriate place.

  -Q quality file       Tell me where to find your mime.types file, if
                        it isn\'t at \$HOME/.qualityrc or \$QUALITYRC.

EOT
    exit 0;
}

if ($versionmode==1) {
    print "ctm.pl version $version, Copyright (C) Axel Beckert <abe\@deuxchevaux.org>\n";
    exit 0;
}

my @mime_file = "";
my %types;
my @mime_locations = ("/usr/local/lib/netscape/mime.types", "/usr/local/lib/mosaic/mime.types");
my @use_mime_locations = ();
my $qualityrc="$ENV{'HOME'}/.qualityrc";
$qualityrc=$ENV{'QUALITYRC'} if exists $ENV{'QUALITYRC'};

while ($ARGV[0] =~ /^-/) {
    $_=shift(@ARGV);
#    warn "Parameter $_ wird gerade verarbeitet! ";
    if ($_ eq "-m") {
	$map_suffix=shift(@ARGV);
    } elsif ($_ eq "-s") {
	@use_suffixes=split(",",shift(@ARGV));
    } elsif ($_ eq "-i") {
	@not_suffixes=split(",",shift(@ARGV));
    } elsif ($_ eq "-M") {
	@use_mime_locations=split(",",shift(@ARGV));
    } elsif ($_ eq "-Q") {
	$qualityrc=shift(@ARGV);
    } else {
	die "Unknown parameter: $_\n $0 --help for help.\n";
    }
}

push(@not_suffixes,$map_suffix);

#print "Files: ".join(", ",@ARGV)."\n";
#print "MIME-Files: ".join(", ",@mime_locations)."\n";

if (@use_mime_locations == 0) {
    foreach (@mime_locations) {
	if (-s) {
	    &openMimeFile($_);
	    last;
	}
    }
    if (-s "$ENV{'HOME'}/.mime.types") {
	&openMimeFile("$ENV{'HOME'}/.mime.types");
    }
} else {
    foreach (@use_mime_locations) {
	if (-s) {
	    &openMimeFile($_);
	} else {
	    warn "$_ doesn't exist or hast zero size!";
	}
    }
}

die "Couldn't read any mime types!" if !%types;

### Output MIME types for debugging
#foreach (sort keys %types) {
#    print "$_: $types{$_}\n";
#}

my %quality;

if (-s $qualityrc) {
    open QUAL,$qualityrc or die "Can't open $qualityrc!";
    while (<QUAL>) {
	chomp;
	s/#.*$//;
	s/ +$//;
	@qualline=split(/\s+/,$_,2);
	if (@qualline>1) {
	    foreach(split(",",$qualline[0])) {
		$quality{$_}=$qualline[1];
	    }
	}
    }
    close QUAL;
}

### Output qualities for debugging
#foreach (sort keys %quality) {
#    print "$_: $quality{$_}\n";
#}

my @filenames=@ARGV;
my @prefixes=();
my $old="";

foreach (sort @filenames) {
    $_ =~ s/\.[^.]*$//;
    push(@prefixes,$_) if $_ ne $old;
    $old=$_;
}

my $filematch;
my @stat;
my $suffix;

if (@use_suffixes>0) {
    $allowed="(".join("|",@use_suffixes).")";
}

$forbidden="\\.(".join("|",@not_suffixes).")\$";

foreach (@prefixes) {
    if (@use_suffixes>0) {
	$filematch="^$_\\.$allowed\$";
    } else {
	$filematch="^$_\\.[^.]*\$";
    }
    print "Creating $_.$map_suffix: ";
    open MAP,">$_.$map_suffix" or die "Can't open $_.$map_suffix for writing!";
    foreach (<$_.*>) {
	if (($_ =~ /$filematch/) and ($_ !~ /$forbidden/)) {
	    $suffix=$_;
	    $suffix=~s/.*\.([^.]*)$/$1/;
	    if (defined $types{$suffix}) {
		@stat=stat($_);
		print "$_ ";
		print MAP "URI: $_\n" ;
		print MAP "Content-type: $types{$suffix}";
		print MAP "; qs=$quality{$suffix}" if defined $quality{$suffix};
		print MAP "\n" ;
		print MAP "Content-length: $stat[7]\n\n";
	    } else {
		warn "Can't determine MIME type of $_ (Suffix: $suffix), ignoring it.";
	    }
	}
    }
    print "\n";
    close MAP;
}

sub openMimeFile {
    my @mimeline;
    my $file=shift;
    open MIME,$file or die "Can't open $file for reading";
    while (<MIME>) {
	chomp;
	s/#.*$//;
	s/ +$//;
	@mimeline=split(/\s+/,$_,2);
	if (@mimeline>1) {
	    foreach (split(/\s+/,$mimeline[1])) {
		$types{$_}=$mimeline[0];
	    }
	}
    }
    close MIME;
}