#!/usr/bin/perl -w

use strict;

# htag.pl - a tagline generator, sig manager and over engineered program.
# Copyright (C) 1999-2003 Project Purple, Simon Huggins

# Simon Huggins <huggie@earth.li>
# http://www.earth.li/projectpurple/progs/htag.html
# For ChangeLog and Known Bugs see HISTORY and BUGS.

 
# 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; version 2 of the License only
#
# 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

# FIXME Check for UNIX first?
if ($< == 0 or $> == 0 or $( == 0 or $) == 0) {
	die "UID/GID or effective UID/GID is 0\n".
	"Htag is no doubt not safe for use when run as root\n";
}
 

# If the "use HtagPlugin 0.5;" line causes problems due to older versions of
# HtagPlugin lying around the system then uncomment the following with the
# path to your local copy of HtagPlugin

# use lib '/home/huggie/perl/huggietag/htag-0.0.24/HtagPlugin';

use HtagPlugin 	0.6;
use Getopt::Long;
use POSIX qw/tcgetpgrp/;

use vars qw(%cfg);
my %override;
my $package_num=0;

# Controls "Doing config filename" messages.
my $cfgdebug=0;

# $infinity is how many times we are allowed to loop in run_plugins
# That is how many times a plugin is allowed to call back to earlier ones.
# The counter is only increased in this case so keep it fairly small but
# increase this if you need to and mail huggie@earth.li to say you did so I
# know what is a sane magic number for future releases.
# Did that make sense?
my $infinity = 80;

### Defines
$override{'VERSION'} = $cfg{'VERSION'}    = "0.0.24";
$override{'HOME'} = $cfg{'HOME'} = $ENV{"HOME"} || $ENV{"LOGDIR"}
	|| (getpwuid($<))[7];
$cfg{'nicedie'} = 1;

# srand(time() ^ ($$ + ($$ << 15) )); # Since 5.004 not required

sub print_header {
	print STDERR "Htag.pl $cfg{'VERSION'} -  Simon Huggins <huggie\@earth.li>  Released under GPL\n";
	print STDERR "Copyright (C) 1999-2002 Project Purple. http://www.earth.li/projectpurple/\n\n";
}

sub process_options {
	$cfg{'basecfgfile'}=$cfg{'HOME'} . "/.htrc";

	$cfg{'debug'} = 0; # default.  Can be overriden in cfgfile
	
	# For process_configfile/undef %cfg logic.
	$override{'basecfgfile'} = $cfg{'basecfgfile'};

	my %getopt=(	"tagfile=s" 	=> \$override{'tagfile'},
			"t=s"		=> \$override{'tagfile'},
			"cfgfile=s"	=> \$override{'basecfgfile'},
			"c=s"		=> \$override{'basecfgfile'},
			"fillsig=s"	=> \$cfg{'fillsig'},
			"f=s"		=> \$cfg{'fillsig'},
			"help"		=> \$cfg{'help'},
			"h"		=> \$cfg{'help'},
			"msgfile=s" 	=> \$cfg{'msgfile'},
			"m=s"		=> \$cfg{'msgfile'});
	if (not &GetOptions(%getopt)) {
		print STDERR <<'EOF';
htag.pl - tagline and general sig adder.
 Usage:   htag.pl -t tagfile -c cfgfile -m msgfile
          htag.pl -h gives perldoc
          htag.pl -f sigfile
	  Fills a sig with spaces to check your @nn@ bits line up (or don't
	  depending what you are trying to achieve).
	  Believe me this is useful.
EOF
		nicedie "\n";
	}

	if (defined $cfg{'fillsig'}) {
		fillsig($cfg{'fillsig'});
		exit;
	}

	if (defined $cfg{'help'}) {
		exec "perldoc $0";
		die "Could not run perldoc.\nPlease less $0 and read the (lack of) documentation at the end\n";
	}

	if (not defined $cfg{'msgfile'}) { 
		print STDERR "No message file?\n";
		nicedie "Sorry you need to give me a message file to add to (or a new filename or -)\n";
	}

	# For process_configfile/undef %cfg logic.
	$override{'msgfile'} = $cfg{'msgfile'};
	$cfg{'basecfgfile'} = $override{'basecfgfile'};
}

sub expand_home_scalar_or_ref($); # suppress warning about unknown prototype
# for the calls to itself inside itself.

sub expand_home_scalar_or_ref($) {
	my $foo = shift;

	return if not defined $foo;

	if (ref($foo) eq 'ARRAY') {
		foreach (@{$foo}) {
			$_ = expand_home_scalar_or_ref($_);
		}
	} elsif (ref($foo) eq 'HASH') {
		foreach my $key (keys %{$foo}) {
			$foo->{$key} = expand_home_scalar_or_ref($foo->{$key});
		}
	} else {
		$foo =~ s#^~/#$cfg{'HOME'}/#o;
	}
	return $foo;
}

sub process_configfile {
	my @list = ($cfg{'basecfgfile'},$cfg{'extracfgfile'});
	undef %cfg;
# nicedie controls whether to ask for keypress when dying (useful when
# normally called by mutt or tin etc.)
# Default to on until cfgfile read.  After all if there is a problem before
# then we want the user to know about it.

	$cfg{'nicedie'} = 1;

	foreach my $cfgfile (@list) {
		print STDERR "Doing $cfgfile\n" if $cfgdebug and defined
			$cfgfile;
		next if not defined $cfgfile;
		unless (my $retval = do "$cfgfile") {
			warn "couldn't parse $cfgfile: $@"
				if $@;
			warn "couldn't do $cfgfile: $!"	
				unless defined $retval;
			warn "couldn't run $cfgfile" 
				unless $retval;
			nicedie "Problem with $cfgfile!  Aborting";
		}
	}

	foreach (keys %override) {
		$cfg{$_} = $override{$_} if defined $override{$_};
	}

	foreach my $key (keys %cfg) {
		if (defined $cfg{$key}) {
			$cfg{$key} = expand_home_scalar_or_ref($cfg{$key});
		}
	}
}

sub run_plugin($) {
	my $program = shift;

	if (-f $program) {
		print STDERR "Running \"$program\"\n" if $cfg{'debug'};
		my ($lines,$rc);
		$rc=0;
# Plugins are allowed to scribble over %cfg but %cfg holds values that must
# be reset (generally) before a second run of the same plugin will work
# (the print "\n" while $cfg{'newline'}--; hit this)
# Plugins can change $cfg{'basecfgfile'} themselves.  This is considered a
# feature.  (Stop laughing at the back there).
# To ensure that plugins written in other languages see the changes to %cfg
# this is done for both forks of the if.
		process_configfile();
		open(H,"<$program");
		$lines = <H>;
		if ($lines =~ m&^#!/[a-zA-Z/.-]+perl .*$&) {
			{ # Otherwise $/ is undef in eval.  Mucho ick.
			local $/;
			undef $/;
			$lines .= <H>;
			close(H);
			}
# I tried to use Safe to do this but it fouls up when using modules.
			$package_num++;
			$program =~ s/.*?([^\/]+)$/$1/;
			my $eval_code = "package HtagPlugin::$package_num;".
			'local $SIG{\'__WARN__\'} = sub { (my $mess = $_[0])'.
			" =~ s/\\(eval[^)]*\\)/$program/g; ".
			' $mess =~ s/(HtagPlugin::)\d+::([^ ]*)/$1$2/; '.
			' warn $mess; }; '.
			"my \$rc = eval {$lines}; ".
			'die $@ if $@; $rc;';

			$_ = "HtagPlugin::$package_num";
			{
			no strict 'refs';
			*{$_.'::cfg'} 		= \%cfg;
			*{$_.'::htagdie'} 	= \&nicedie;
			*{$_.'::subst_macros'}	= \&subst_macros;
			*{$_.'::scansigfile'}	= \&scansigfile;
			*{$_.'::process_msgbody'}
						= \&process_msgbody;
			*{$_.'::process_configfile'}
						= \&process_configfile;
			*{$_.'::chunksizealign'}
						= \&chunksizealign;
			*{$_.'::reg_deletion'}
						= \&reg_deletion;
			}
			$rc = eval $eval_code;
			$override{'notag'} = $cfg{'notag'} if defined $cfg{'notag'};
			if ($@) {
				$@ =~ s/\(eval[^)]*\)/$program/g;
				nicedie "$program: $@";
			}
			if (not defined $rc) {
				$rc = 253;
			}
		} else {
# if not perl construct arg list
			my @args    =  ($cfg{'msgfile'},$cfg{'basecfgfile'},
					$cfg{'VERSION'});
			close(H);
			$rc = 0xffff & system($program,@args);
			$rc >>= 8;
		}
		
		if ($rc == 254) {
			my $msg="";
			$msg = "Plugin control, plugin $program requesting clearance to die...\n" if $cfg{'debug'};
			nicedie $msg; # Ensure we wait on a keypress if asekd to
		} elsif ($rc == 255) {
			my $msg="";
			$msg = "User requested death... Complying.\n" if $cfg{'debug'};
			die $msg;
		}

		return $rc unless $rc == 253;
	} else {
		# XXX Don't die?
		nicedie "$program does not exist!\n";
	}
	return;
}


sub pick_rand(\@) {
	my $ref = shift;
	return @{$ref}[rand scalar @{$ref}];
}

sub run_plugins($) {
	my $dir = shift;
	my (@plugins,%plugins,$program);

	opendir(DIR, $dir) or nicedie "Cannot open $dir: $!\n";
	@plugins = 	grep { -f $_     }
			map  { $dir . $_ }
			grep { ! /^\./   }
			readdir(DIR);
	closedir(DIR);

	foreach my $plugin (@plugins) {
		if ($plugin !~ m#/(\d\d).+$#) {
			nicedie "Found unexpected $plugin\n";
		} else {
			push @{$plugins{$1}}, $plugin;
		}
	}

	my @order = sort keys %plugins;
	my (@trueorder,$infinite_loop);

	$infinite_loop=0;
	@trueorder = @order;

	while (my $num = shift @order) {
		$program = pick_rand(@{$plugins{$num}});
		if (my $back = run_plugin($program)) {
			my @redo=@trueorder;
			while ($redo[0] < $back) {
				shift @redo;
			}
			@order = @redo;
			$infinite_loop++;
			if ($infinite_loop > $infinity) {
				nicedie "Purple Alert!  This is not a daffodil!  Too much recursion\n".
				"This probably happened because your taglines are too short compared to the\n".
				"space left in the sig chosen.\n";
			}
		}
	}
}

sub fillsig($) {
	my $sigfile = shift;
	my ($sig,$len,$type);

	open(HANDLE, $sigfile) or nicedie "Could not open $sigfile!: $!";
	while (<HANDLE>) {
		$sig .= $_;
	}
	close(HANDLE);

	while ($sig =~   /@[A-Za-z]?[1-9][0-9]*[RC]?@/) {
		$sig =~ s/@[A-Za-z]?([1-9][0-9]*)[RC]?@/" "x$1/e;
	}
	$sig =~ s/\@V/$cfg{'VERSION'}/g;

	print $sig;
}

sub choose_configfile() {
	process_configfile(); # Pick up the changeconf stuff.

	return $cfg{'basecfgfile'} if not defined $cfg{'changeheaders'};

	my $file;

	if (defined $cfg{'changeheaders'}) {
		my (@headers,$match,@l);
		if (open(HANDLE, $cfg{'msgfile'})) {
			while (my $line = <HANDLE>) {
				last if ($line =~ /^$/); # end of headers
				push @headers, $line;
			}
			close(HANDLE);
		}
		foreach (@{$cfg{'changeheaders'}}) {
			$file = pop;
			foreach (@$_) {
				eval { "" =~ /$_/; };
				nicedie "Pattern \"$_\" would have killed me if I'd tried to run it.\nPerl said: $@" if $@;
			}
		}
# Ugh.
# There must be a nicer way to implement this?
	CH:	foreach (@{$cfg{'changeheaders'}}) {
			@l = @$_;
			$match=0;
			$file = pop @l;
			foreach my $line (@headers) {
	PAT:			foreach my $pattern (@l) {
					if ($line =~ /$pattern/) {
						my $temp = $1;
						$file =~ s/\$1/$temp/e
							if defined $temp;
						$match++;
						last PAT;
					}
				}
				if ($match == @l or $l[0] eq "") {
					$override{'extracfgfile'} =
						$cfg{'extracfgfile'} = $file;
					last CH;
				}
			}
			if (not @headers and $l[0] eq "") {
				$override{'extracfgfile'} =
					$cfg{'extracfgfile'} = $file;
				last CH;

			}
		}
	}
}

### START HERE

{
print_header;
process_options;
choose_configfile;
process_configfile;
if (not defined $cfg{'plugindir'}) {
	nicedie "Sorry, \$cfg{'plugindir'} was not defined in your config file.\n";
}
if ($cfg{'plugindir'} !~ m#/$#) { $cfg{'plugindir'} .= "/"; }
run_plugins($cfg{'plugindir'});
}

END {
	&delete_tmpfiles;
}

__END__

=head1 NAME

htag.pl - Add taglines and sigs to email, news and fidonet messages.

=head1 SYNOPSIS

htag.pl [I<-t> tagfile I<-c> cfgfile] I<-m> msgfile

htag.pl I<-f> sigfile

htag.pl I<-h>

=head1 DESCRIPTION

B<htag.pl> is a sigmonster.  It is designed to be extendable in many
different ways through its use of plugins.  It might be getting a little bit
too sentient in its old age though.

It can be used like this:

htag.pl -m $1

$EDITOR $1

For information on configuration see the B<sample.htrc> file

To create signature files, it is tedious to have to work out what will and
won't line up.  This is why the I<-f> option exists.  Feed it a sigfile
and it will replace the @[0-9]+[RC]?@ bits with required number of spaces so
you can see if you got it right or not.  (You could even run it from your
favourite editor  e.g. C<:! htag.pl -f %> for vim on the current file.)

=head1 BUGS

Inserting a tagline containing C<@[0-9]+[RC]?@> has interesting
results.

This documentation is useless.  Use The Source Luke.

=head1 FILES

=over 4

=item ~/.htrc

Config file

=back

=head1 SEE ALSO

http://www.earth.li/progs/htag.html

=head1 AUTHOR

Simon Huggins <huggie@earth.li>

=cut