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