#!/usr/bin/perl
# script to insert a PICS header in an HTML file, just prior
# to the end or the header (</HEAD>)

# Copyright 1996 Andrew Daviel, Vancouver-Webpages.com
# You may do what you like with this except sell it or say you wrote it.
# This is free software. No warranty is expressed or implied.

# *** WARNING - This script modifies HTML documents in-place. Back up
# *** your pages before using. The author takes no responsibility for any
# *** damage to files that may occur as a result of using this script.

if (@ARGV[0] =~ /^-\w/) { $arg = shift(@ARGV) ; }

if ($arg eq "-R") { $force = 1 ; }
if ($arg eq "-h") { 
  print <<EOT;
Usage: $0 [-R] <htmlfile> <tagfile>

Text in <tagfile> is inserted just prior to the </HEAD> tag in <htmlfile>. 
The ownership and permissions of the old file are preserved.
The optional argument "-R" causes existing PICS headers to be replaced.
If a PICS header already exists, a warning is generated.
                
Typical usage to tag a whole site:
find /usr/local/etc/httpd/htdocs  -name "*.html" -exec $0 {} PICS.general \\;

 *** WARNING - This script modifies HTML documents in-place. Back up
 *** your pages before using. The author takes no responsibility for any
 *** damage to files that may occur as a result of using this script.
EOT
  exit ;
} 
$f = @ARGV[0] ; $m = @ARGV[1] ;
$t = "/tmp/add-meta.tmp" ;

if (!$f || !$m) {
  print <<EOT;
$0 copyright 1996 Andrew Daviel, Vancouver-Webpages.com
This script is intended to insert PICS header in HTML files.
For more about PICS, see "http://www.w3.org/pub/WWW/PICS/" .
For help on command-line arguments, use "$0 -h"

Entering Interactive Mode.

EOT
  $user = $ENV{'USER'} ;
  if ($user ne "root") { $access = "-user ".$user ; }
  $m=&promptuser("Name of file containing PICS header to insert","") ;
  $tree=&promptuser("Tag an entire site (directory tree) (y/n)","N") ;
  $tree=~ tr/A-Z/a-z/ ; $tree = ($tree =~/^y/) ;
  $force = &promptuser("Strip existing PICS headers (y/n)","N");
  $force =~ tr/A-Z/a-z/ ; $force = ($force =~/^y/) ;
  if ($tree) {
    print "This script uses Unix \"find\" to follow a directory tree.
It does not follow httpd aliases. Only files writable by $user
will be modified.\n";
    $root = &promptuser("Name of document root","/usr/local/etc/httpd/htdocs") ;
    print "Types of file to tag (*.html, *.htm, *html etc.)\n";
    $html = &promptuser("Files to tag","*.html") ;
    $files = $root."/".$html ;
  } else {
    $f = &promptuser("Name of file to tag","") ; $files = $f ;
  }
  print <<EOT;
WARNING - This script modifies HTML documents in-place.
WARNING - Back up $files before proceeding.
WARNING - The author takes no responsibility for any damage to files.
EOT
  $exit = &promptuser("Proceed (y/n)","") ;
  $exit =~ tr/A-Z/a-z/ ; $exit = ($exit =~/^y/) ;
  if (!$exit) { exit ; }
  if ($tree) {
    open (MOD,$m) || die "Can't open META file $m\n";
    while (<MOD>) {
      if (/http-equiv\s*=\W*PICS-Label/i) { $mpics++ ; }
    }
    close (MOD) ;
    if ($force) {$force = "-R" ; }
    if (!$mpics && !$force) {
      print "ERROR - the file $m does not appear to contain a PICS label\n";
      exit ;
    }
    print "Executing 'find $root $access -name \"$html\"  -exec $0 $force {} $m \\;'\n" ;
    system("find $root $access -name \"$html\"  -exec $0 $force {} $m \\;") ;
    exit ;
  }
}
#print "Modify file $f, add text from $m\n";
open (FILE,$f) || die "Can't open input file $f" ;
@fstat=stat($f) ; # get stat

open (TMP,">".$t) || die "Can't open temporary file $t" ;
open (MOD,$m) || die "Can't open META file $m\n";
while (<MOD>) {
  if (/http-equiv\s*=\W*PICS-Label/i) { $mpics++ ; }
}
close (MOD) ;
if (!$mpics && !$force) {
  print "ERROR - the file $m does not appear to contain a PICS label\n";
  exit ;
}
open (MOD,$m) || die "Can't open META file $m\n";
$del = 0 ;
while (<FILE>) {
  if (m%<HEAD>%i) { $head++ ; }
  if (/http-equiv\s*=\W*PICS-Label/i) { 
    $pics= $_ ; if (!$head) { print "Warning - Existing PICS tag before <HEAD>\n"; }
    if ($arg eq "-r" || $arg eq "-R") { # set delete flag
      $del=1 ; 
      print "Deleting existing PICs tag $_\n";
    } 
  }
  if (m%</HEAD>%i) { 
    $l1 = $_ ; $l2 = $_ ;
    $l1 =~ s%</HEAD>.*%%i ; # before /head
    $l2 =~ s%.*</HEAD>%%i ; # after /head
    if ($l1) {print TMP "$l1"; } 
    while (<MOD>) { print TMP "$_" ; }
    print TMP "</HEAD>" ;
    if ($l2) {print TMP "$l2"; }
    $end++ ;
    if ($del) {
      $err++ ; print "ERROR - </HEAD> found inside PICS header\n"; 
    }
  } else {
    if (!$del) {print TMP "$_" ; }
  }
  if (/\)\s*\)\s*'\s*>/) { $del = 0 ; }
}
if (!$end) { $err++ ; print "ERROR - No </HEAD> found in $f\n"; }
if (!$head) { $err++ ; print "ERROR - No <HEAD> found in $f\n"; }
if ($pics) {  print "An existing PICS header was found in $f\n"; }
close (FILE) ; close (TMP) ; close (MOD) ;
if ($err) { exit ; }
system("mv $t $f") && die "Can't mv $t to $f" ;

# $fstat[x] 2 mode, 4 uid 5 gid 7 size 8 atime 9 mtime 10 ctime
chmod($fstat[2],$f) || die "Can't change mode to $fstat[2] for $f" ;
chown($fstat[4],$fstat[5],$f) || 
  die "Can't change UID, GID to $fstat[4],$fstat[5] for $f" ;
utime($fstat[8],$fstat[9],$f) || die "Can't change atime,mtime for $f";
print "Updated file $f\n";
unlink($t) ;


sub promptuser {
    ($promptstring, $defval) = @_;
    print "$promptstring ($defval) :";
    $useranswer = <STDIN>;
    chop $useranswer;
    if ($useranswer =~ /^$/) {
        return $defval;
    } else {
        return $useranswer;
    }
}
