htag.pl

   1 #!/usr/bin/perl -w
   2
   3 use strict;
   4
   5 # htag.pl - a tagline generator, sig manager and over engineered program.
   6 # Copyright (C) 1999-2003 Project Purple, Simon Huggins
   7
   8 # Simon Huggins <huggie@earth.li>
   9 # http://www.earth.li/projectpurple/progs/htag.html
  10 # For ChangeLog and Known Bugs see HISTORY and BUGS.
  11
  12
  13 # This program is free software; you can redistribute it and/or modify it
  14 # under the terms of the GNU General Public License as published by the Free
  15 # Software Foundation; version 2 of the License only
  16 #
  17 # This program is distributed in the hope that it will be useful, but
  18 # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  19 # or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  20 # for more details.
  21 #
  22 # You should have received a copy of the GNU General Public License along
  23 # with this program; if not, write to the Free Software Foundation, Inc., 59
  24 # Temple Place, Suite 330, Boston, MA 02111-1307  USA
  25
  26 # FIXME Check for UNIX first?
  27 if ($< == 0 or $> == 0 or $( == 0 or $) == 0) {
  28         die "UID/GID or effective UID/GID is 0\n".
  29         "Htag is no doubt not safe for use when run as root\n";
  30 }
  31
  32
  33 # If the "use HtagPlugin 0.5;" line causes problems due to older versions of
  34 # HtagPlugin lying around the system then uncomment the following with the
  35 # path to your local copy of HtagPlugin
  36
  37 # use lib '/home/huggie/perl/huggietag/htag-0.0.24/HtagPlugin';
  38
  39 use HtagPlugin  0.6;
  40 use Getopt::Long;
  41 use POSIX qw/tcgetpgrp/;
  42
  43 use vars qw(%cfg);
  44 my %override;
  45 my $package_num=0;
  46
  47 # Controls "Doing config filename" messages.
  48 my $cfgdebug=0;
  49
  50 # $infinity is how many times we are allowed to loop in run_plugins
  51 # That is how many times a plugin is allowed to call back to earlier ones.
  52 # The counter is only increased in this case so keep it fairly small but
  53 # increase this if you need to and mail huggie@earth.li to say you did so I
  54 # know what is a sane magic number for future releases.
  55 # Did that make sense?
  56 my $infinity = 80;
  57
  58 ### Defines
  59 $override{'VERSION'} = $cfg{'VERSION'}    = "0.0.24";
  60 $override{'HOME'} = $cfg{'HOME'} = $ENV{"HOME"} || $ENV{"LOGDIR"}
  61         || (getpwuid($<))[7];
  62 $cfg{'nicedie'} = 1;
  63
  64 # srand(time() ^ ($$ + ($$ << 15) )); # Since 5.004 not required
  65
  66 sub print_header {
  67         print STDERR "Htag.pl $cfg{'VERSION'} -  Simon Huggins <huggie\@earth.li>  Released under GPL\n";
  68         print STDERR "Copyright (C) 1999-2002 Project Purple. http://www.earth.li/projectpurple/\n\n";
  69 }
  70
  71 sub process_options {
  72         $cfg{'basecfgfile'}=$cfg{'HOME'} . "/.htrc";
  73
  74         $cfg{'debug'} = 0; # default.  Can be overriden in cfgfile
  75
  76         # For process_configfile/undef %cfg logic.
  77         $override{'basecfgfile'} = $cfg{'basecfgfile'};
  78
  79         my %getopt=(    "tagfile=s"     => \$override{'tagfile'},
  80                         "t=s"           => \$override{'tagfile'},
  81                         "cfgfile=s"     => \$override{'basecfgfile'},
  82                         "c=s"           => \$override{'basecfgfile'},
  83                         "fillsig=s"     => \$cfg{'fillsig'},
  84                         "f=s"           => \$cfg{'fillsig'},
  85                         "help"          => \$cfg{'help'},
  86                         "h"             => \$cfg{'help'},
  87                         "msgfile=s"     => \$cfg{'msgfile'},
  88                         "m=s"           => \$cfg{'msgfile'});
  89         if (not &GetOptions(%getopt)) {
  90                 print STDERR <<'EOF';
  91 htag.pl - tagline and general sig adder.
  92  Usage:   htag.pl -t tagfile -c cfgfile -m msgfile
  93           htag.pl -h gives perldoc
  94           htag.pl -f sigfile
  95           Fills a sig with spaces to check your @nn@ bits line up (or don't
  96           depending what you are trying to achieve).
  97           Believe me this is useful.
  98 EOF
  99                 nicedie "\n";
 100         }
 101
 102         if (defined $cfg{'fillsig'}) {
 103                 fillsig($cfg{'fillsig'});
 104                 exit;
 105         }
 106
 107         if (defined $cfg{'help'}) {
 108                 exec "perldoc $0";
 109                 die "Could not run perldoc.\nPlease less $0 and read the (lack of) documentation at the end\n";
 110         }
 111
 112         if (not defined $cfg{'msgfile'}) {
 113                 print STDERR "No message file?\n";
 114                 nicedie "Sorry you need to give me a message file to add to (or a new filename or -)\n";
 115         }
 116
 117         # For process_configfile/undef %cfg logic.
 118         $override{'msgfile'} = $cfg{'msgfile'};
 119         $cfg{'basecfgfile'} = $override{'basecfgfile'};
 120 }
 121
 122 sub expand_home_scalar_or_ref($); # suppress warning about unknown prototype
 123 # for the calls to itself inside itself.
 124
 125 sub expand_home_scalar_or_ref($) {
 126         my $foo = shift;
 127
 128         return if not defined $foo;
 129
 130         if (ref($foo) eq 'ARRAY') {
 131                 foreach (@{$foo}) {
 132                         $_ = expand_home_scalar_or_ref($_);
 133                 }
 134         } elsif (ref($foo) eq 'HASH') {
 135                 foreach my $key (keys %{$foo}) {
 136                         $foo->{$key} = expand_home_scalar_or_ref($foo->{$key});
 137                 }
 138         } else {
 139                 $foo =~ s#^~/#$cfg{'HOME'}/#o;
 140         }
 141         return $foo;
 142 }
 143
 144 sub process_configfile {
 145         my @list = ($cfg{'basecfgfile'},$cfg{'extracfgfile'});
 146         undef %cfg;
 147 # nicedie controls whether to ask for keypress when dying (useful when
 148 # normally called by mutt or tin etc.)
 149 # Default to on until cfgfile read.  After all if there is a problem before
 150 # then we want the user to know about it.
 151
 152         $cfg{'nicedie'} = 1;
 153
 154         foreach my $cfgfile (@list) {
 155                 print STDERR "Doing $cfgfile\n" if $cfgdebug and defined
 156                         $cfgfile;
 157                 next if not defined $cfgfile;
 158                 unless (my $retval = do "$cfgfile") {
 159                         warn "couldn't parse $cfgfile: $@"
 160                                 if $@;
 161                         warn "couldn't do $cfgfile: $!"
 162                                 unless defined $retval;
 163                         warn "couldn't run $cfgfile"
 164                                 unless $retval;
 165                         nicedie "Problem with $cfgfile!  Aborting";
 166                 }
 167         }
 168
 169         foreach (keys %override) {
 170                 $cfg{$_} = $override{$_} if defined $override{$_};
 171         }
 172
 173         foreach my $key (keys %cfg) {
 174                 if (defined $cfg{$key}) {
 175                         $cfg{$key} = expand_home_scalar_or_ref($cfg{$key});
 176                 }
 177         }
 178 }
 179
 180 sub run_plugin($) {
 181         my $program = shift;
 182
 183         if (-f $program) {
 184                 print STDERR "Running \"$program\"\n" if $cfg{'debug'};
 185                 my ($lines,$rc);
 186                 $rc=0;
 187 # Plugins are allowed to scribble over %cfg but %cfg holds values that must
 188 # be reset (generally) before a second run of the same plugin will work
 189 # (the print "\n" while $cfg{'newline'}--; hit this)
 190 # Plugins can change $cfg{'basecfgfile'} themselves.  This is considered a
 191 # feature.  (Stop laughing at the back there).
 192 # To ensure that plugins written in other languages see the changes to %cfg
 193 # this is done for both forks of the if.
 194                 process_configfile();
 195                 open(H,"<$program");
 196                 $lines = <H>;
 197                 if ($lines =~ m&^#!/[a-zA-Z/.-]+perl .*$&) {
 198                         { # Otherwise $/ is undef in eval.  Mucho ick.
 199                         local $/;
 200                         undef $/;
 201                         $lines .= <H>;
 202                         close(H);
 203                         }
 204 # I tried to use Safe to do this but it fouls up when using modules.
 205                         $package_num++;
 206                         $program =~ s/.*?([^\/]+)$/$1/;
 207                         my $eval_code = "package HtagPlugin::$package_num;".
 208                         'local $SIG{\'__WARN__\'} = sub { (my $mess = $_[0])'.
 209                         " =~ s/\\(eval[^)]*\\)/$program/g; ".
 210                         ' $mess =~ s/(HtagPlugin::)\d+::([^ ]*)/$1$2/; '.
 211                         ' warn $mess; }; '.
 212                         "my \$rc = eval {$lines}; ".
 213                         'die $@ if $@; $rc;';
 214
 215                         $_ = "HtagPlugin::$package_num";
 216                         {
 217                         no strict 'refs';
 218                         *{$_.'::cfg'}           = \%cfg;
 219                         *{$_.'::htagdie'}       = \&nicedie;
 220                         *{$_.'::subst_macros'}  = \&subst_macros;
 221                         *{$_.'::scansigfile'}   = \&scansigfile;
 222                         *{$_.'::process_msgbody'}
 223                                                 = \&process_msgbody;
 224                         *{$_.'::process_configfile'}
 225                                                 = \&process_configfile;
 226                         *{$_.'::chunksizealign'}
 227                                                 = \&chunksizealign;
 228                         *{$_.'::reg_deletion'}
 229                                                 = \&reg_deletion;
 230                         }
 231                         $rc = eval $eval_code;
 232                         $override{'notag'} = $cfg{'notag'} if defined $cfg{'notag'};
 233                         if ($@) {
 234                                 $@ =~ s/\(eval[^)]*\)/$program/g;
 235                                 nicedie "$program: $@";
 236                         }
 237                         if (not defined $rc) {
 238                                 $rc = 253;
 239                         }
 240                 } else {
 241 # if not perl construct arg list
 242                         my @args    =  ($cfg{'msgfile'},$cfg{'basecfgfile'},
 243                                         $cfg{'VERSION'});
 244                         close(H);
 245                         $rc = 0xffff & system($program,@args);
 246                         $rc >>= 8;
 247                 }
 248
 249                 if ($rc == 254) {
 250                         my $msg="";
 251                         $msg = "Plugin control, plugin $program requesting clearance to die...\n" if $cfg{'debug'};
 252                         nicedie $msg; # Ensure we wait on a keypress if asekd to
 253                 } elsif ($rc == 255) {
 254                         my $msg="";
 255                         $msg = "User requested death... Complying.\n" if $cfg{'debug'};
 256                         die $msg;
 257                 }
 258
 259                 return $rc unless $rc == 253;
 260         } else {
 261                 # XXX Don't die?
 262                 nicedie "$program does not exist!\n";
 263         }
 264         return;
 265 }
 266
 267
 268 sub pick_rand(\@) {
 269         my $ref = shift;
 270         return @{$ref}[rand scalar @{$ref}];
 271 }
 272
 273 sub run_plugins($) {
 274         my $dir = shift;
 275         my (@plugins,%plugins,$program);
 276
 277         opendir(DIR, $dir) or nicedie "Cannot open $dir: $!\n";
 278         @plugins =      grep { -f $_     }
 279                         map  { $dir . $_ }
 280                         grep { ! /^\./   }
 281                         readdir(DIR);
 282         closedir(DIR);
 283
 284         foreach my $plugin (@plugins) {
 285                 if ($plugin !~ m#/(\d\d).+$#) {
 286                         nicedie "Found unexpected $plugin\n";
 287                 } else {
 288                         push @{$plugins{$1}}, $plugin;
 289                 }
 290         }
 291
 292         my @order = sort keys %plugins;
 293         my (@trueorder,$infinite_loop);
 294
 295         $infinite_loop=0;
 296         @trueorder = @order;
 297
 298         while (my $num = shift @order) {
 299                 $program = pick_rand(@{$plugins{$num}});
 300                 if (my $back = run_plugin($program)) {
 301                         my @redo=@trueorder;
 302                         while ($redo[0] < $back) {
 303                                 shift @redo;
 304                         }
 305                         @order = @redo;
 306                         $infinite_loop++;
 307                         if ($infinite_loop > $infinity) {
 308                                 nicedie "Purple Alert!  This is not a daffodil!  Too much recursion\n".
 309                                 "This probably happened because your taglines are too short compared to the\n".
 310                                 "space left in the sig chosen.\n";
 311                         }
 312                 }
 313         }
 314 }
 315
 316 sub fillsig($) {
 317         my $sigfile = shift;
 318         my ($sig,$len,$type);
 319
 320         open(HANDLE, $sigfile) or nicedie "Could not open $sigfile!: $!";
 321         while (<HANDLE>) {
 322                 $sig .= $_;
 323         }
 324         close(HANDLE);
 325
 326         while ($sig =~   /@[A-Za-z]?[1-9][0-9]*[RC]?@/) {
 327                 $sig =~ s/@[A-Za-z]?([1-9][0-9]*)[RC]?@/" "x$1/e;
 328         }
 329         $sig =~ s/\@V/$cfg{'VERSION'}/g;
 330
 331         print $sig;
 332 }
 333
 334 sub choose_configfile() {
 335         process_configfile(); # Pick up the changeconf stuff.
 336
 337         return $cfg{'basecfgfile'} if not defined $cfg{'changeheaders'};
 338
 339         my $file;
 340
 341         if (defined $cfg{'changeheaders'}) {
 342                 my (@headers,$match,@l);
 343                 if (open(HANDLE, $cfg{'msgfile'})) {
 344                         while (my $line = <HANDLE>) {
 345                                 last if ($line =~ /^$/); # end of headers
 346                                 push @headers, $line;
 347                         }
 348                         close(HANDLE);
 349                 }
 350                 foreach (@{$cfg{'changeheaders'}}) {
 351                         $file = pop;
 352                         foreach (@$_) {
 353                                 eval { "" =~ /$_/; };
 354                                 nicedie "Pattern \"$_\" would have killed me if I'd tried to run it.\nPerl said: $@" if $@;
 355                         }
 356                 }
 357 # Ugh.
 358 # There must be a nicer way to implement this?
 359         CH:     foreach (@{$cfg{'changeheaders'}}) {
 360                         @l = @$_;
 361                         $match=0;
 362                         $file = pop @l;
 363                         foreach my $line (@headers) {
 364         PAT:                    foreach my $pattern (@l) {
 365                                         if ($line =~ /$pattern/) {
 366                                                 my $temp = $1;
 367                                                 $file =~ s/\$1/$temp/e
 368                                                         if defined $temp;
 369                                                 $match++;
 370                                                 last PAT;
 371                                         }
 372                                 }
 373                                 if ($match == @l or $l[0] eq "") {
 374                                         $override{'extracfgfile'} =
 375                                                 $cfg{'extracfgfile'} = $file;
 376                                         last CH;
 377                                 }
 378                         }
 379                         if (not @headers and $l[0] eq "") {
 380                                 $override{'extracfgfile'} =
 381                                         $cfg{'extracfgfile'} = $file;
 382                                 last CH;
 383
 384                         }
 385                 }
 386         }
 387 }
 388
 389 ### START HERE
 390
 391 {
 392 print_header;
 393 process_options;
 394 choose_configfile;
 395 process_configfile;
 396 if (not defined $cfg{'plugindir'}) {
 397         nicedie "Sorry, \$cfg{'plugindir'} was not defined in your config file.\n";
 398 }
 399 if ($cfg{'plugindir'} !~ m#/$#) { $cfg{'plugindir'} .= "/"; }
 400 run_plugins($cfg{'plugindir'});
 401 }
 402
 403 END {
 404         &delete_tmpfiles;
 405 }
 406
 407 __END__
 408
 409 =head1 NAME
 410
 411 htag.pl - Add taglines and sigs to email, news and fidonet messages.
 412
 413 =head1 SYNOPSIS
 414
 415 htag.pl [I<-t> tagfile I<-c> cfgfile] I<-m> msgfile
 416
 417 htag.pl I<-f> sigfile
 418
 419 htag.pl I<-h>
 420
 421 =head1 DESCRIPTION
 422
 423 B<htag.pl> is a sigmonster.  It is designed to be extendable in many
 424 different ways through its use of plugins.  It might be getting a little bit
 425 too sentient in its old age though.
 426
 427 It can be used like this:
 428
 429 htag.pl -m $1
 430
 431 $EDITOR $1
 432
 433 For information on configuration see the B<sample.htrc> file
 434
 435 To create signature files, it is tedious to have to work out what will and
 436 won't line up.  This is why the I<-f> option exists.  Feed it a sigfile
 437 and it will replace the @[0-9]+[RC]?@ bits with required number of spaces so
 438 you can see if you got it right or not.  (You could even run it from your
 439 favourite editor  e.g. C<:! htag.pl -f %> for vim on the current file.)
 440
 441 =head1 BUGS
 442
 443 Inserting a tagline containing C<@[0-9]+[RC]?@> has interesting
 444 results.
 445
 446 This documentation is useless.  Use The Source Luke.
 447
 448 =head1 FILES
 449
 450 =over 4
 451
 452 =item ~/.htrc
 453
 454 Config file
 455
 456 =back
 457
 458 =head1 SEE ALSO
 459
 460 http://www.earth.li/progs/htag.html
 461
 462 =head1 AUTHOR
 463
 464 Simon Huggins <huggie@earth.li>
 465
 466 =cut