1;# $Id$ 2;# 3;# Copyright (c) 1990-2006, Raphael Manfredi 4;# 5;# You may redistribute only under the terms of the Artistic License, 6;# as specified in the README file that comes with the distribution. 7;# You may reuse parts of this distribution only within the terms of 8;# that same Artistic License; a copy of which may be found at the root 9;# of the source tree for mailagent 3.0. 10;# 11;# $Log: actions.pl,v $ 12;# Revision 3.0.1.21 2001/03/17 18:10:47 ram 13;# patch72: use the "email" config var verbatim in FORWARD 14;# patch72: removed unused var in POST 15;# 16;# Revision 3.0.1.20 2001/03/13 13:13:15 ram 17;# patch71: made fixup of header fields in POST be a warning 18;# patch71: fixed RESYNC, copied continuation fix from parse_mail() 19;# patch71: added support for SUBST/TR on mail headers 20;# 21;# Revision 3.0.1.19 2001/01/10 16:52:58 ram 22;# patch69: replaced calls to fake_date() by mta_date() 23;# patch69: rewrote the POST command, and added the -b switch 24;# 25;# Revision 3.0.1.18 1999/07/12 13:49:01 ram 26;# patch66: use servshell instead of /bin/sh for commands 27;# patch66: make sure that we do not get an empty header when filtering 28;# 29;# Revision 3.0.1.17 1999/01/13 18:12:18 ram 30;# patch64: only use last two digits from year in logfiles 31;# 32;# Revision 3.0.1.16 1997/09/15 15:10:53 ram 33;# patch57: don't blindly chop command error message, remove trailing \n 34;# patch57: annotation was not performed for value "0" 35;# 36;# Revision 3.0.1.15 1997/02/20 11:42:06 ram 37;# patch55: made 'perl -cw' clean and fixed a couple of typos 38;# 39;# Revision 3.0.1.14 1997/01/07 18:31:14 ram 40;# patch52: allow for @SH help to be understood, whatever the case 41;# 42;# Revision 3.0.1.13 1996/12/24 14:46:16 ram 43;# patch45: now reads 'help' as 'mailhelp' in command messages 44;# patch45: locate and perform security checks on launched executables 45;# 46;# Revision 3.0.1.12 1995/09/15 14:01:17 ram 47;# patch43: now escapes shell metacharacters for popen() on FORWARD and BOUNCE 48;# patch43: will now make a note when delivering to an unlocked folder 49;# patch43: saving will fail if mbox_lock returns an undefined value 50;# 51;# Revision 3.0.1.11 1995/08/07 16:16:44 ram 52;# patch37: now use env::biff instead of cf:biff for dynamic configuration 53;# patch37: added protection around &interface::reset calls for perl5 54;# 55;# Revision 3.0.1.10 1995/02/16 14:32:26 ram 56;# patch32: now uses new header_append and header_prepend routines 57;# 58;# Revision 3.0.1.9 1995/02/03 17:58:11 ram 59;# patch30: was wrongly biffing when delivering to a mail hook 60;# patch30: avoid perl core dumps in &perl by localizing @_ on entry 61;# 62;# Revision 3.0.1.8 1995/01/25 15:19:45 ram 63;# patch27: added support for NFS bug on remote read-only folders 64;# patch27: destination address for PROCESS is now parsed correctly 65;# patch27: added support for folder mode change, as defined by PROTECT 66;# 67;# Revision 3.0.1.7 1995/01/03 18:04:55 ram 68;# patch24: removed a here-doc string to workaround a bug in perl 4.0 PL36 69;# patch24: simplified action codes to use new opt'sw_xxx option vars 70;# patch24: &execute_command no longer sleeps before resuming parent process 71;# 72;# Revision 3.0.1.6 1994/10/29 17:45:01 ram 73;# patch20: added biffing support in &save 74;# 75;# Revision 3.0.1.5 1994/10/04 17:46:37 ram 76;# patch17: now uses the email config parameter to send messages to user 77;# patch17: new routine &trace_dump to dump messages in ~/agent.trace 78;# patch17: PROCESS now ensures the return address is not hostile 79;# patch17: shell commands receiving SIGPIPE now always mail trace back 80;# 81;# Revision 3.0.1.4 1994/09/22 14:07:26 ram 82;# patch12: now updates new variable folder_saved with folder path 83;# patch12: added various escapes in strings for perl5 support 84;# patch12: create ~/agent.trace if unable to mail command trace back 85;# patch12: interface change for &qmail allows for better log messages 86;# patch12: implements new AFTER and DO filtering commands 87;# 88;# Revision 3.0.1.3 1994/07/01 14:57:49 ram 89;# patch8: timeout for RUN commands now defined by runmax config variable 90;# patch8: now systematically escape leading From if fromall is ON 91;# 92;# Revision 3.0.1.2 1994/04/25 15:16:53 ram 93;# patch7: here and there fixes 94;# patch7: global fix for From line escapes to make them configurable 95;# 96;# Revision 3.0.1.1 1994/01/26 09:30:03 ram 97;# patch5: restored ability to use Cc: and Bcc: in message files 98;# 99;# Revision 3.0 1993/11/29 13:48:33 ram 100;# Baseline for mailagent 3.0 netwide release. 101;# 102;# 103# 104# Implementation of filtering commands 105# 106 107# The "LEAVE" command 108# Leave a copy of the message in the mailbox. Returns (mbox, failed_status) 109sub leave { 110 local($mailbox) = &mailbox_name; # Incomming mailbox filename 111 &add_log("starting LEAVE") if $loglvl > 15; 112 &save($mailbox); # Propagate return status 113} 114 115# The "SAVE" command 116# Save a message in a folder. Returns (mbox, failed_status). If the folder 117# already exists and has the 'x' bit set, then is is understood as an external 118# hook and mailhook is invoked. If the folder name begins with '+', it is 119# handled as an MH folder. If the folder is actually a directory, then message 120# is saved in an individual file, much like an MH folder. 121sub save { 122 local($mailbox) = @_; # Where mail should be saved 123 local($failed) = 0; # Printing status 124 if ($mailbox eq '') { # Empty mailbox (e.g. SAVE %1 with no match) 125 $mailbox = &mailbox_name; 126 &add_log("WARNING empty folder name, using $mailbox") if $loglvl > 5; 127 } 128 local($biffing) = $env'biff =~ /ON/i; # Whether we should biff or not 129 local($type) = 'file'; # Folder type, for biffing macros 130 &add_log("starting SAVE $mailbox") if $loglvl > 15; 131 if ($mailbox =~ s/^\+//) { # MH folder? 132 $type = 'MH'; 133 $failed = &mh'save($mailbox); 134 } elsif (-d $mailbox) { # A directory hook 135 $failed = &mh'savedir($mailbox); 136 $type = 'dir'; 137 } elsif (-x $mailbox) { # Folder hook 138 $failed = &save_hook; # Deliver to program 139 $biffing = 0; # No biffing for hooks 140 } else { # Saving to a normal folder 141 # Uncompress folders if necessary. The restore routine will perform 142 # the necessary checks and return immediately if no compression is 143 # wanted for that particular folder. However, we can avoid the overhead 144 # of calling this routine (and loading it when using dataloading) if 145 # the 'compress' configuration parameter is missing. 146 &compress'restore($mailbox) if $cf'compress; 147 $failed = &save_folder($mailbox); 148 } 149 &add_log("ERROR could not save mail in $mailbox") if $failed && $loglvl; 150 &emergency_save if $failed; 151 152 # At this point, folder_saved has been updated to the path of the folder 153 # where message has been saved, unless it was a hook but in that case we 154 # do not biff anyway. 155 &biff($folder_saved, $type) if $biffing && !$failed; 156 157 ($mailbox, $failed); # Where save was made and failure status 158} 159 160# Called by &save when folder is a regular one (i.e. not a hook). 161sub save_folder { 162 local($mailbox) = @_; # Where mail should be saved 163 local($amount); # Amount of bytes written 164 local($failed); 165 # Explicitely check for writable mailbox. I've seen an NFS between a SUN 166 # and a file on DEC OSF/1 accept appending while file was read-only... 167 # We may only perform the open if the file does not exist or is writable. 168 local($exist) = -e $mailbox; # Run chmod if PROTECT used and created 169 local($mayopen) = !$exist || -w _; 170 if ($mayopen && open(MBOX, ">>$mailbox")) { 171 172 local($ret) = &mbox_lock($mailbox); # Lock mailbox, get exclusive access 173 return 1 unless defined $ret; # Unable to lock, fail miserably 174 local($size) = -s $mailbox; # Initial mailbox size 175 176 # It's still possible we did not get any lock on the mailbox, or just 177 # a partial lock, but the user did tell us that was ok, via the 178 # 'locksafe' variable setting. Simply emit a notice that we're 179 # delivering without locking. 180 181 &add_log("NOTICE saving to non-locked $mailbox") 182 if !$ret && $loglvl > 6; 183 184 # If MMDF-style mailboxes are allowed, then the saving routine will 185 # try to determine what kind of folder it is delivering to and choose 186 # the right format. Otherwise, standard Unix format is assumed. 187 188 if ($cf'mmdf =~ /on/i) { # MMDF-style allowed 189 # Save to mailbox, selecting the right format (UNIX vs MMDF) 190 ($failed, $amount) = &mmdf'save(*MBOX, $mailbox); 191 } else { 192 # Save to UNIX folder 193 ($failed, $amount) = &mmdf'save_unix(*MBOX); 194 } 195 196 # Because we might write over NFS, and because we might have had to 197 # force fate to get a lock, it is wise to make sure the folder has the 198 # right size, which would tend to indicate the mail made it to the 199 # buffer cache, if not to the disk itself. 200 local($should) = $size + $amount; # Computed new size for mailbox 201 local($new_size) = -s $mailbox; # Last write was flushed to disk 202 &add_log("ERROR $mailbox has $new_size bytes (should have $should)") 203 if $new_size != $should && $loglvl; 204 $failed = 1 if $new_size != $should; 205 206 # Finally, release the lock on the mailbox and close the file. If the 207 # closing operation fails for whatever reason, the routine will return 208 # a 1, so $failed will be set. Of course, "normally" it should not 209 # fail at that point, since the mail was previously flushed. 210 $failed |= &mbox_unlock($mailbox); # Will close file 211 212 # Now adjust permissions on the file, if created and PROTECT was used. 213 &mmdf'chmod($env'protect, $mailbox) if !$exist && defined $env'protect; 214 215 } else { 216 local($msg) = $mayopen ? "$!" : 'Permission denied'; 217 &add_log("SYSERR open: $msg") if $loglvl; 218 if (-f "$mailbox") { 219 &add_log("ERROR cannot append to $mailbox") if $loglvl; 220 } else { 221 &add_log("ERROR cannot create $mailbox") if $loglvl; 222 } 223 $failed = 1; 224 } 225 $folder_saved = $mailbox; # Keep track of last folder we save into 226 $failed; # Propagate failure status 227} 228 229# Called by &save when folder is a hook. 230# Note that as opposed to other folder saving routines, we do not update the 231# $folder_saved variable when saving into a hook. This is because the hook 232# might be another set of filtering rules or a perl escape taking care of its 233# own saving, in which case we do not want to corrupt the saved location. 234# Return command failure status. 235sub save_hook { 236 local($failed) = &hook'process($mailbox); 237 &add_log("HOOKED [$mfile]") if !$failed && $loglvl > 2; 238 $failed; # Propagate failure status 239} 240 241# The "PROCESS" command 242# The body of the message is expected to be in $Header{'Body'} 243sub process { 244 local($subj) = $Header{'Subject'}; 245 local($msg_id) = $Header{'Message-Id'}; 246 local($sender) = $Header{'Reply-To'}; 247 local($to) = $Header{'To'}; 248 local($bad) = ""; # No bad commands 249 local($pack) = "auto"; # Default packing mode for sending files 250 local($ncmd) = 0; # Number of valid commands we have found 251 local($dest) = ""; # Destination (where to send answers) 252 local(@cmd); # Array of all commands 253 local(%packmode); # Records pack mode for each command 254 local($error) = 0; # Error report code 255 local(@body); # Body of message 256 257 &add_log("starting PROCESS") if $loglvl > 15; 258 259 # If no @PATH directive was found, use $sender as a return path 260 $dest = $Userpath; # Set by an @PATH 261 $dest = $sender unless $dest; 262 # Remove the <> if any (e.g. path derived from Return-Path) 263 $dest = (&parse_address($dest))[0]; 264 265 # Debugging purposes 266 &add_log("\@PATH was '$Userpath' and sender was '$sender'") 267 if $loglvl > 18; 268 &add_log("computed destination: $dest") if $loglvl > 15; 269 270 # Make sure address is not hostile. Since a transcript is sent to the 271 # sender computed in $dest, we cannot inform the user if the address 272 # turns out to be really hostile. 273 274 unless (&addr'valid($dest)) { 275 &add_log("ERROR $dest is an hostile sender address") if $loglvl > 1; 276 &add_log("NOTICE discarding whole command mail") if $loglvl > 6; 277 return 0; # An error would requeue message 278 } 279 280 # Copy body of message in an array, one line per entry 281 @body = split(/\n/, $Header{'Body'}); 282 283 # The command file contains the authorized commands 284 if ($#command < 0) { # Command file not processed yet 285 open(COMMAND, "$cf'comfile") || &fatal("No command file!"); 286 while (<COMMAND>) { 287 chop; 288 $command{$_} = 1; 289 } 290 close(COMMAND); 291 } 292 293 line: foreach (@body) { 294 # Built-in commands 295 if (/^\@PACK\s*(.*)/) { # Pack mode 296 $pack = $1 if $1 ne ''; 297 $pack = "" if ($pack =~ /[=$^&*([{}`\\|;><?]/); 298 } 299 s/^[ \t]\@SH/\@SH/; # allow one blank only 300 if (/^\@SH/) { 301 s/\\!/!/g; # if uucp address, un-escape `!' 302 if (/[=\$^&*([{}`\\|;><?]/) { 303 s/^\@SH/bad command:/; # space after ":" will be added 304 $bad .= $_ . "\n"; 305 next line; 306 } 307 # Some useful substitutions 308 s/\@SH[ \t]*//; # Allow leading blanks 309 s/ PATH/ $dest/; # PATH is a macro 310 s/^mial(\w*)/mail$1/; # Common mis-spellings 311 s/^mailpath/mailpatch/; 312 s/^mailist/maillist/; 313 s/^help/mailhelp/i; 314 # Now fetch command's name (first symbol) 315 if (/^([^ \t]+)[ \t]/) { 316 $first = $1; 317 } else { 318 $first = $_; 319 } 320 if (!$command{$first}) { # if un-authorized cmd 321 s/^/unknown cmd: /; # needs a space after ":" 322 $bad .= $_ . "\n"; 323 next line; 324 } 325 $packmode{$_} = $pack; # packing mode for this command 326 push(@cmd, $_); # record command 327 } 328 } 329 330 # ************* Check with authoritative file **************** 331 332 # Do not continue if an error occurred, in which case the mail will remain 333 # in the queue and will be processed later on. 334 return $error if $error || $dest eq ''; 335 336 # Now we are sure the mail we proceed is for us 337 $sender = "<someone>" if $sender eq ''; 338 $ncmd = $#cmd + 1; 339 if ($ncmd > 1) { 340 &add_log("$ncmd commands for $sender") if $loglvl > 11; 341 } elsif ($ncmd == 1) { 342 &add_log("1 command for $sender") if $loglvl > 11; 343 } else { 344 &add_log("no command for $sender") if $loglvl > 11; 345 } 346 foreach $fullcmd (@cmd) { 347 $cmdfile = "/tmp/mess.cmd$$"; 348 open(CMD,">$cmdfile"); 349 # For our children 350 print CMD "jobnum=$jobnum export jobnum\n"; 351 print CMD "fullcmd=\"$fullcmd\" export fullcmd\n"; 352 print CMD "pack=\"$packmode{$fullcmd}\" export pack\n"; 353 print CMD "path=\"$dest\" export path\n"; 354 print CMD "sender=\"$sender\" export sender\n"; 355 print CMD "set -x\n"; 356 print CMD "$fullcmd\n"; 357 close CMD; 358 $fullcmd =~ /^[ \t]*(\w+)/; # extract first word 359 $cmdname = $1; # this is the command name 360 $trace = "$cf'tmpdir/trace.cmd$$"; 361 362 # For HPUX-10.x, grrr... have to use our own shell otherwise that 363 # silly posix /bin/sh dumps core when fed the $cmdfile we built above. 364 local($shell) = &cmdserv'servshell; 365 366 $pid = fork; # We fork here 367 $pid = -1 unless defined $pid; 368 369 if ($pid == 0) { 370 open(STDOUT, ">$trace"); # Where output goes 371 open(STDERR, ">&STDOUT"); # Make it follow pipe 372 exec $shell, "$cmdfile"; # Don't use sh -c 373 } elsif ($pid == -1) { 374 # Set the error report code, and the mail will remain in queue 375 # for later processing. Any @RR in the message will be re-executed 376 # but it is not really important. In fact, this is going to be 377 # a feature, not a bug--RAM. 378 $error = 1; 379 &add_log("ERROR cannot fork: $!") if $loglvl > 0; 380 unless (open(MAILER,"|$cf'sendmail $cf'mailopt $dest $cf'email")) { 381 &add_log("SYSERR fork: $!") if $loglvl; 382 &add_log("ERROR cannot launch $cf'sendmail") if $loglvl; 383 } 384 print MAILER <<EOM; 385To: $dest 386Subject: $cmdname not executed 387$MAILER 388 389Your command was: $fullcmd 390 391It was not executed because I could not fork. Sigh ! 392(Kernel report: $!) 393 394The command has been left in a queue and will be processed again 395as soon as possible, so it is useless to resend it. 396 397-- mailagent speaking for $cf'user 398EOM 399 close MAILER; 400 if ($?) { 401 &add_log("ERROR cannot report failure") if $loglvl; 402 } 403 return $error; # Abort processing now--mail remains in queue 404 } else { 405 wait(); 406 if ($?) { 407 unless ( 408 open(MAILER,"|$cf'sendmail $cf'mailopt $dest $cf'email") 409 ) { 410 &add_log("SYSERR fork: $!") if $loglvl; 411 &add_log("ERROR cannot launch $cf'sendmail") if $loglvl; 412 } 413 print MAILER <<EOM; 414To: $dest 415Subject: $cmdname returned a non-zero status 416$MAILER 417 418Your command was: $fullcmd 419It produced the following output and failed: 420 421EOM 422 if (open(TRACE, $trace)) { 423 while (<TRACE>) { 424 print MAILER; 425 } 426 close TRACE; 427 } else { 428 print MAILER "** SORRY - NOT AVAILABLE **\n"; 429 &add_log("ERROR cannot dump trace") if $loglvl; 430 } 431 print MAILER "\n-- mailagent speaking for $cf'user\n"; 432 close MAILER; 433 if ($?) { 434 &add_log("ERROR cannot report failure") if $loglvl; 435 &trace_dump($trace, "failed $fullcmd"); 436 } 437 &add_log("FAILED $fullcmd") if $loglvl > 1; 438 } else { 439 &add_log("OK $fullcmd") if $loglvl > 5; 440 } 441 } 442 unlink $cmdfile, $trace; 443 } 444 445 if ($bad) { 446 unless (open(MAILER,"|$cf'sendmail $cf'mailopt $dest $cf'email")) { 447 &add_log("SYSERR fork: $!") if $loglvl; 448 &add_log("ERROR cannot launch $cf'sendmail") if $loglvl; 449 } 450 chop($bad); # Remove trailing new-line 451 # For unknown reasons, perl 4.0 PL36 chokes here when a here-document 452 # syntax is used. Although it compiles fine, no output seems to be 453 # sent on the MAILER descriptor. Use a string then... That's funny 454 # though becase here-document syntax is used elsewhere without problems. 455 print MAILER 456"To: $dest 457Subject: the following commands were not executed 458$MAILER 459 460$bad 461 462If $cf'name can figure out what you wanted, he may do it anyway. 463 464-- mailagent speaking for $cf'user 465"; 466 close MAILER; 467 if ($?) { 468 &add_log("ERROR unable to mail back bad commands from $sender") 469 if $loglvl; 470 } 471 &add_log("bad commands from $sender") if $loglvl > 5; 472 } 473 474 &add_log("all done for $sender") if $loglvl > 11; 475 $error; # Return error report (0 for ok) 476} 477 478# The "MACRO" command 479sub macro { 480 local($args) = @_; # name = (value, type) 481 local($replace) = $opt'sw_r; # Replace existing macro 482 local($delete) = $opt'sw_d; # Delete macro 483 local($pop) = $opt'sw_p; # Pop macro 484 local($name); # Macro's name 485 if ($delete || $pop) { # Macro is to be deleted or popped 486 ($name) = $args =~ /(\S+)/; # Get first "word" 487 &usrmac'pop($name) if $pop; # Pop last value, delete if last 488 &usrmac'delete($name) if $delete; 489 return ($name, $pop ? 'popped' : 'deleted'); # Propagate action 490 } 491 # There are two formats for the macro command. The first format uses the 492 # 'name = (val, type)' template and can be used to specify any kind of 493 # macro (see usrmac.pl). The other form is name ..., where ... is any 494 # kind of string --including spaces-- which will be used as a SCALAR 495 # value. Of course, that string cannot take the '= (val, type)' format. 496 local($val); # Macro's value 497 local($type) = 'SCALAR'; # Assume scalar type 498 if ($args =~ /(\S+)\s*=\s*\(\s*(.*),\s*(\w+)\s*\)\s*/) { 499 ($name, $val, $type) = ($1, $2, $3); 500 } else { 501 ($name, $val) = $args =~ /(\S+)\s+(.*)/; # SCALAR type assumed 502 } 503 &usrmac'new($name, $val, $type) if $replace; 504 &usrmac'push($name, $val, $type) unless $replace; 505 ($name, $replace ? 'replaced' : 'pushed'); # Propagate action 506} 507 508# The "MESSAGE" command 509sub message { 510 local($msg) = @_; # Vacation message to be sent back 511 local(@head) = ( 512 "To: %r (%N)", 513 "Subject: Re: %R" 514 ); 515 local($to) = '%r'; # Recipient is macro %r 516 ¯os_subst(*to); # Evaluate it so we can give it to mailer 517 &send_message($msg, *head, $to); 518} 519 520# The "NOTIFY" command 521sub notify { 522 local($msg, $address) = @_; 523 # Any address included withing "" means addresses are stored in a file 524 $address = &complete_list($address, 'address'); 525 $address =~ s/%/%%/g; # Protect all '%' (subject to macro substitution) 526 local($to) = $address; # For the To: line... 527 $to =~ s/\s+/, /g; # Addresses separated by ',' on the To: line 528 local(@head) = ( 529 "To: $to", 530 "Subject: %s (notification)" 531 ); 532 &send_message($msg, *head, $address); 533} 534 535# Send a given message to somebody, as specified in the given header 536# The message and the header are subject to macro substitution. 537# Usually, when using sendmail, the -t option could be used to parse header 538# and obtain the recipients. However, the mailer being configurable, we cannot 539# assume it will understand -t. Therefore, the recipients must be specified. 540sub send_message { 541 local($msg, *header, $recipients) = @_; # Message to send, header, where 542 unless (-f "$msg") { 543 &add_log("ERROR cannot find message $msg") if $loglvl > 0; 544 return 1; 545 } 546 unless (open(MSG, "$msg")) { 547 &add_log("ERROR cannot open message $msg") if $loglvl > 0; 548 return 1; 549 } 550 551 # Construction of value for the %T macro 552 local($macro_T); # Default value of macro %T is overwritten 553 local($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime, $mtime, 554 $ctime,$blksize,$blocks) = stat($msg); 555 local($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = 556 localtime($mtime); 557 local($this_year) = (localtime(time))[5]; 558 # Do not put the year in %T if it is the same as the current one. 559 ++$mon; # Month in the range 1-12 560 if ($this_year != $year) { 561 $macro_T = sprintf("%.2d/%.2d/%.2d", $year % 100, $mon, $mday); 562 } else { 563 $macro_T = sprintf("%.2d/%.2d", $mon, $mday); 564 } 565 566 # Header construction. If the file contains a header at the top, it is 567 # added to the one we already have by default. Identical fields are 568 # overwritten with the one found in the file. 569 # BUG: Multiple line headers are incorrectly overridden by the grep() 570 # below: only the first line is taken into account! 571 if (&header_found($msg)) { # Top of message is a header 572 local(@newhead); # New header is constructed here 573 local($cc) = ''; # Carbon copy recipients 574 local($collect) = 0; # True when collecting recipients 575 local($field); 576 local($_); 577 while (<MSG>) { # Read the header then 578 last if /^$/; # End of header 579 chop; 580 push(@newhead, $_); 581 if (/^([\w\-]+):(.*)/) { 582 $field = $1; 583 $_ = $2; 584 @head = grep(!/^$field:/, @head); # Field is overwritten 585 586 # The following used to be done directly by sendmail -t. 587 # However, mailagent does not make use of that option any 588 # longer since $cf'sendmail might not be sendmail and the 589 # mailer used might therefore not understand this -t option. 590 591 $collect = ($field =~ /^b?cc$/i); 592 $cc .= ¯os_subst(*_) if $collect; 593 } else { 594 $cc .= ¯os_subst(*_) if $collect; # Continuation lines 595 } 596 } 597 foreach (@newhead) { 598 push(@head, $_); 599 } 600 601 # Now update the recipient line by parsing $cc and extracting the 602 # e-mail addresses, discarding the comments. Note that this code 603 # will fail if ',' is used in address comments. 604 605 local(@addr) = split(/,/, $cc); 606 foreach $addr (@addr) { 607 $recipients .= ' ' . (&parse_address($addr))[0]; 608 } 609 } 610 611 # Remove duplicate e-mail addresses in the recipient list. Again, 612 # mailagent used to rely on sendmail to do this, but we can't assume 613 # any user-defined mailer will do it. 614 local(%seen); 615 foreach $addr (split(' ', $recipients)) { 616 $seen{$addr}++; 617 } 618 $recipients = join(' ', sort keys %seen); 619 undef %seen; 620 621 unless (open(MAILER,"|$cf'sendmail $cf'mailopt $recipients")) { 622 &add_log("ERROR cannot run $cf'sendmail to send message: $!") 623 if $loglvl; 624 close MSG; 625 return 1; 626 } 627 628 push(@head, $FILTER); # Avoid loops: replying to ourselves or whatever 629 foreach $line (@head) { 630 ¯os_subst(*line); # In-place macro substitutions 631 print MAILER "$line\n"; # Write header 632 } 633 print MAILER "\n"; # Header separated from body 634 # Now write the body 635 local($tmp); # Because of a bug in perl 4.0 PL19 636 while (defined ($tmp = <MSG>)) { 637 next if $tmp =~ /^$/ && $. == 1; # Escape sequence to protect header 638 ¯os_subst(*tmp); # In-place macro substitutions 639 print MAILER $tmp; # Write message line 640 } 641 642 # Close pipe and check status 643 close MSG; 644 close MAILER; 645 local($status) = $?; 646 unless ($status) { 647 if ($loglvl > 2) { 648 local($dest) = $head[0]; # The To: header line 649 ($dest) = $dest =~ m|^To:\s+(.*)|; 650 &add_log("SENT message to $dest"); 651 } 652 } else { 653 &add_log("ERROR could not mail back $msg") if $loglvl > 1; 654 } 655 $status; # 0 for success 656} 657 658# The "FORWARD" command 659sub forward { 660 local($addresses) = @_; # Address(es) mail should be forwarded to 661 local($address) = $cf'email; # Address of user 662 # Any address included withing "" is in fact a file name where actual 663 # forwarding addresses are found. 664 $addresses = 665 &complete_list($addresses, 'address'); # Process "include-requests" 666 local($saddr); # Address list for shell command 667 ($saddr = $addresses) =~ s/([()'"<>$;])/\\$1/g; 668 unless (open(MAILER,"|$cf'sendmail $cf'mailopt $saddr")) { 669 &add_log("ERROR cannot run $cf'sendmail to forward message: $!") 670 if $loglvl; 671 return 1; 672 } 673 local $SIG{PIPE} = 'IGNORE'; # sendmail failure caught at close() time 674 local(@addr) = split(' ', $addresses); 675 print MAILER &header'format("Resent-From: $address"), "\n"; 676 local($to) = "Resent-To: " . join(', ', @addr); 677 print MAILER &header'format($to), "\n"; 678 # Protect Sender: and Resent-: lines in the original message 679 foreach (split(/\n/, $Header{'Head'})) { 680 next if /^From\s+(\S+)/; 681 s/^Sender:\s*(.*)/Prev-Sender: $1/; 682 s/^Resent-([\w\-]+):\s*(.*)/Prev-Resent-$1: $2/; 683 print MAILER $_, "\n"; 684 } 685 print MAILER $FILTER, "\n"; 686 print MAILER "\n"; 687 # If sendmail is used and there is no -i flag in the options, we need to 688 # escape dots on a line by themselves. 689 if ($cf'sendmail =~ /\bsendmail\b/ && $cf'mailopt !~ /-i\b/) { 690 my $body = $Header{'Body'}; 691 $body =~ s/^\./../gm; 692 print MAILER $body; 693 &add_log("WARNING sendmail used -- you should add -i to mailopt") 694 if $loglvl > 2; 695 } else { 696 print MAILER $Header{'Body'}; 697 } 698 close MAILER; 699 local($failed) = $?; # Status of forwarding 700 if ($failed) { 701 &add_log("ERROR could not forward to $addresses") if $loglvl > 1; 702 } 703 $failed; # 0 for success 704} 705 706# The "BOUNCE" command 707sub bounce { 708 local($addresses) = @_; # Address(es) mail should be bounced to 709 # Any address included withing "" is in fact a file name where actual 710 # bouncing addresses are found. 711 $addresses = 712 &complete_list($addresses, 'address'); # Process "include-requests" 713 local($saddr); # Address list for shell command 714 ($saddr = $addresses) =~ s/([()'"<>$;])/\\$1/g; 715 unless (open(MAILER,"|$cf'sendmail $cf'mailopt $saddr")) { 716 &add_log("ERROR cannot run $cf'sendmail to bounce message: $!") 717 if $loglvl; 718 return 1; 719 } 720 local $SIG{PIPE} = 'IGNORE'; # sendmail failure caught at close() time 721 # Protect Sender: lines in the original message 722 foreach (split(/\n/, $Header{'Head'})) { 723 next if /^From\s+(\S+)/; 724 s/^Sender:\s*(.*)/Prev-Sender: $1/; 725 print MAILER $_, "\n"; 726 } 727 print MAILER $FILTER, "\n"; 728 print MAILER "\n"; 729 # If sendmail is used and there is no -i flag in the options, we need to 730 # escape dots on a line by themselves. 731 if ($cf'sendmail =~ /\bsendmail\b/ && $cf'mailopt !~ /-i\b/) { 732 my $body = $Header{'Body'}; 733 $body =~ s/^\./../gm; 734 print MAILER $body; 735 &add_log("WARNING sendmail used -- you should add -i to mailopt") 736 if $loglvl > 2; 737 } else { 738 print MAILER $Header{'Body'}; 739 } 740 close MAILER; 741 local($failed) = $?; # Status of forwarding 742 if ($failed) { 743 &add_log("ERROR could not bounce to $addresses") if $loglvl > 1; 744 } 745 $failed; # 0 for success 746} 747 748# The "POST" command 749sub post { 750 local($newsgroups) = @_; # Newsgroup(s) mail should be posted to 751 local($localdist) = $opt'sw_l; # Local distribution if POST -l 752 local($wantbiff) = $opt'sw_b; # Biffing activated upon success 753 unless (open(NEWS,"|$cf'sendnews $cf'newsopt -h")) { 754 &add_log("ERROR cannot run $cf'sendnews to post message: $!") 755 if $loglvl; 756 return 1; 757 } 758 &add_log("distribution of posting is local") 759 if $loglvl > 18 && $localdist; 760 761 # The From: header we're generating in the news is correctly formatted 762 # and escaped, to avoid rejects by the news server. 763 # We'll let any Reply-To header through, since RFC-1036 defines them 764 # for this purpose (i.e. the same as for mail), but we don't reformat 765 # the Reply-To since it's not a required header. 766 my ($faddr, $fcom) = &parse_address($Header{'From'}); 767 $fcom = '"' . $fcom . '"' if $fcom =~ /[@.\(\)<>,:!\/=;]/; 768 if ($fcom ne '') { 769 print NEWS header::news_fmt("From: $fcom <$faddr>\n"); 770 } else { 771 print NEWS "From: $faddr\n"; 772 } 773 774 # The Date: field must be parseable by INN, and not be in the future 775 # or the article would be rejected. Articles too far in the past (outside 776 # the history range) are also rejected, but we don't know what is 777 # configured. As a precaution, dates older than 14 days (the default INN 778 # setting) are patched. 779 unless (defined $Header{'Date'} && $Header{'Date'} ne '') { 780 &add_log("WARNING no Date, faking one") if $loglvl > 5; 781 my $date = &header'mta_date(); 782 print NEWS "Date: $date\n"; 783 } else { 784 my $str = $Header{'Date'}; 785 my $when = &header'parsedate($str); 786 my $now = time; 787 my $date; 788 my $AGEMAX = 10 * 86400; # 10 days 789 my $THRESH = 86400; # 1 day 790 my $WARN_THRESH = 600; # 10 minutes 791 if ($when < 0) { 792 &add_log("WARNING can't parse Date field '$str', adjusting") 793 if $loglvl > 5; 794 $date = &header'mta_date($now); 795 } elsif ($when > $now) { 796 my $rel = &relative_age($when - $now); 797 my $adjusting = ''; 798 my $stamp = $when; 799 my $delta = $when - $now; 800 if ($delta >= $THRESH) { # More than a day, adjust! 801 $stamp = $now; 802 $adjusting = ", adjusting"; 803 } 804 &add_log("WARNING Date field is $rel in the future$adjusting") 805 if $loglvl > 5 && $delta >= $WARN_THRESH; 806 $date = &header'mta_date($stamp); 807 } elsif (($now - $when) >= $AGEMAX) { 808 my $rel = &relative_age($now - $when); 809 &add_log("WARNING Date field too ancient ($rel), adjusting") 810 if $loglvl > 5; 811 $date = &header'mta_date($now - $AGEMAX + 3600); 812 } else { 813 $date = &header'mta_date($when); # Regenerate properly 814 } 815 print NEWS "Date: $date\n"; 816 print NEWS "X-Orig-Date: $str\n" if lc($date) ne lc($str); 817 } 818 819 # If no Subject is present, fake one to make inews happy 820 unless (defined($Header{'Subject'}) && $Header{'Subject'} ne '') { 821 &add_log("WARNING no Subject, faking one") if $loglvl > 5; 822 print NEWS "Subject: <none>\n"; 823 } else { 824 my $subject = $Header{'Subject'}; 825 $subject =~ tr/\n/ /; # Multiples instances collapsed 826 print NEWS header::news_fmt("Subject: $subject\n"); 827 } 828 829 # If no proper Message-ID is present, generate one 830 # If one is present, perform sanity fixups because INN is really picky 831 my $msgid; 832 unless (defined($Header{'Message-Id'}) && $Header{'Message-Id'} ne '') { 833 &add_log("WARNING no Message-Id, faking one") if $loglvl > 5; 834 $msgid = &gen_message_id; 835 } else { 836 ($msgid) = $Header{'Message-Id'} =~ /(<[^>]+@[^>]+>)/; 837 if ($msgid ne '') { 838 # Fixups are always the same, therefore they don't prevent proper 839 # duplicate detection provided all feeds are done from mailagent 840 # But we also need to fix places using those message IDs, i.e. 841 # the References line, to preserve correct threading (see below). 842 my $fixup = header::msgid_cleanup(\$msgid); 843 &add_log("WARNING fixed Message-Id line for news") 844 if $loglvl > 5 && $fixup; 845 } else { 846 &add_log("WARNING bad Message-Id line, faking one") if $loglvl > 5; 847 $msgid = &gen_message_id; 848 } 849 } 850 print NEWS "Message-ID: $msgid\n"; 851 852 # If there is a Followup-To line, ignore it, unless it says "poster". 853 my $followup = $Header{'Followup-To'}; 854 if ($followup =~ /\bposter\b/) { 855 print NEWS "Followup-To: poster\n"; 856 } elsif ($followup ne '') { 857 &add_log("WARNING stripped Followup-To: $followup") 858 if $loglvl > 5; 859 } 860 861 # Protect Sender: lines in the original message and clean-up header 862 local($last_was_header); # Set to true when header is skipped 863 864 # Need at most one of the following headers, lest article might be rejected 865 my %single = map { lc($_) => 0 } qw( 866 Mime-Version 867 Content-Transfer-Encoding 868 Content-Type 869 Reply-To 870 ); 871 872 foreach (split(/\n/, $Header{'Head'})) { 873 next if /^From\s/; # First From line... 874 if ( 875 /^From:/i || # This one was cleaned up above 876 /^Subject:/i || # This one handled above 877 /^Message-Id:/i || # idem 878 /^Followup-To:/i || # idem 879 /^Date:/i || # idem 880 /^In-Reply-To:/i || 881 /^References:/i || # One will be faked if missing 882 /^Apparently-To:/i || 883 /^Distribution:/i || # No mix-up, please 884 /^Control:/i || 885 /^Xref:/i || 886 /^NNTP-Posting-.*:/i || # Cleanup for NNTP server 887 /^Originator:/i || # Probably from news->mail gateway 888 /^Newsgroups:/i || # Reply from news reader 889 /^Return-Receipt-To:/i || # Sendmail's acknowledgment 890 /^Received:/i || # We want to remove this MTA trace 891 /^Delivered-To:/i || # idem 892 /^Precedence:/i || 893 /^DKIM-Signature:/i || # INN2 does not like this field 894 /^Accept-?[\w-]*:/i || # INN2 does not like this field 895 /^Auth-?[\w-]*:/i || # INN2 does not like this field 896 /^X-[\w-]+:/i || # INN2 does not like these fields 897 /^Injection-[\w-]+:/i || # INN2 does not like these fields 898 /^Errors-To:/i # Error report redirection 899 ) { 900 $last_was_header = 1; # Mark we discarded the line 901 next; # Line is skipped 902 } 903 # Skip any RFC-822 header that is not purely made up of [\w-]+ 904 # as it is not possible it can be meaningful to the news system. 905 if (/^([!-9;-~\w-]+):/) { 906 my $header = $1; 907 $header = &header::normalize($header); 908 unless ($header =~ /^[\w-]+$/) { 909 &add_log("NOTICE droping RFC-822 header \"$header\" for news") 910 if $loglvl > 5; 911 $last_was_header = 1; # Mark we discarded the line 912 next; # Line is skipped 913 } 914 # All headers will now match /^[\w-]+:/ 915 if ($Header{$header} =~ /^\s*$/) { 916 &add_log("NOTICE dropping empty header \"$header\" for news") 917 if $loglvl > 5; 918 $last_was_header = 1; # Mark we discarded the line 919 next; # Line is skipped 920 } 921 } 922 s/^Sender:/Prev-Sender:/i; 923 s/^(To|Cc):/X-$1:/i; # Keep distribution info 924 s/^(Resent-\w+):/X-$1:/i; 925 if (/^([\w-]+):/ && exists $single{"\L$1"}) { 926 my $field = lc($1); 927 if ($single{$field}++) { 928 my $nfield = &header'normalize($field); 929 &add_log("WARNING stripping dup $nfield header") 930 if $loglvl > 5 && $single{$field} == 2; 931 $last_was_header = 1; # Mark we discarded the line 932 next; # Line is skipped 933 } 934 } 935 next if /^\s/ && $last_was_header; # Skip removed header continuations 936 $last_was_header = 0; # We decided to keep header line 937 s/^([\w-]+):\s+/$1: /; # INN2 is picky: wants one space 938 939 # Ensure that we always put a single space after the field name 940 # (before possibly emitting a newline for the continuation) 941 if (s/^([\w-]+):(\S)/$1: $2/ || s/^([\w-]+):$/$1: /) { 942 my $header = $1; 943 &add_log("NOTICE added space after \"$header:\", for news") 944 if $loglvl > 5; 945 } 946 # We include the "\n" at the end of the string to let news_fmt() 947 # avoid emitting the line if it ends-up being a blank line: since 948 # we are emitting a header, that blank line would signal EOH. 949 print NEWS header::news_fmt("$_\n"); 950 } 951 952 # For correct threading, we need a References: line. 953 my $refs = $Header{'References'}; # Will probably be missing 954 $refs =~ tr/\n/ /; # Must be ONE line 955 my $inreply = $Header{'In-Reply-To'}; # Should not be missing for replies 956 my ($replyid) = $inreply =~ /(<[^>]+>)/; 957 958 # Warn only when there's no message ID in the In-Reply-To header and 959 # there is no References line: this will prevent correct threading. 960 # We assume the References line was correctly setup when it is present. 961 &add_log("WARNING In-Reply-To header did not contain any message ID") 962 if $loglvl > 5 && $inreply ne '' && $replyid eq '' && $refs =~ /^\s*$/; 963 964 if ($replyid ne '' && $refs ne '' && $refs !~ /\Q$replyid/) { 965 $refs .= " $replyid"; 966 &add_log("NOTICE added missing In-Reply-To ID to References") 967 if $loglvl > 6; 968 } 969 $refs = $replyid unless $refs ne ''; 970 if ($refs ne '') { 971 my $fixup = &header'msgid_cleanup(\$refs); 972 &add_log("WARNING fixed References line for news") 973 if $loglvl > 5 && $fixup; 974 # INN does not like an empty References: line, even if properly 975 # followed by continuations. Therefore, cheat to force the message 976 # to have at least one ref on the line. 977 print NEWS header::news_fmt("References: $refs\n"); 978 } 979 980 # Any address included withing "" means addresses are stored in a file 981 $newsgroups = &complete_list($newsgroups, 'newsgroup'); 982 $newsgroups =~ s/\s/,/g; # Cannot have spaces between them 983 $newsgroups =~ tr/,/,/s; # Squash down consecutive ',' 984 print NEWS header::news_fmt("Newsgroups: $newsgroups\n"); 985 print NEWS "Distribution: local\n" if $localdist; 986 print NEWS $FILTER, "\n"; # Avoid loops: inews may forward to sendmail 987 print NEWS "\n"; 988 print NEWS $Header{'Body'}; 989 close NEWS; 990 local($failed) = $?; # Status of forwarding 991 if ($failed) { 992 &add_log("ERROR could not post to $newsgroups") if $loglvl > 1; 993 } else { 994 &biff($newsgroups, "news") if $wantbiff; 995 } 996 $failed; # 0 for success 997} 998 999# The "APPLY" command 1000sub apply { 1001 local($rulefile) = @_; 1002 # Prepare new environment for apply_rules 1003 local($ever_saved) = 0; 1004 local($ever_matched) = 0; 1005 # Now call apply_rules, with no statistics recorded, propagating the 1006 # current mode we are in and using an alternate rule file. 1007 local($saved, $matched) = 1008 &rules'alternate($rulefile, 'apply_rules', $wmode, 0); 1009 if (!defined($saved)) { 1010 &add_log("ERROR could not apply rule file $rulefile") if $loglvl > 1; 1011 return (1, 0); # Notify failure 1012 } 1013 # Since APPLY will fail when no save, warn the user 1014 if (!$matched) { 1015 &add_log("NOTICE no match in $rulefile") if $loglvl > 6; 1016 } else { 1017 &add_log("NOTICE no save in $rulefile") if !$saved && $loglvl > 6; 1018 } 1019 (0, $saved); # Mail was correctly filtered, but was it saved? 1020} 1021 1022# The "SPLIT" command 1023# This routine is RFC-934 compliant and will correctly burst digests produced 1024# with this RFC in mind. For instance, MH produces RFC-934 style digest. 1025# However, in order to reliably split non RFC-934 digest, some extra work is 1026# performed to ensure a meaningful output. 1027sub split { 1028 local($folder) = @_; # Folder to save messages into 1029 # Option parsing: a -i splits "inplace", i.e. acts as a saving if the split 1030 # is fully successful. A -d discards the leading part. Queues messsages 1031 # instead of filling them into a folder if the folder name is empty. 1032 local($inplace) = $opt'sw_i; # Inplace (original marked saved) 1033 local($discard) = $opt'sw_d; # Discard digest leading part 1034 local($empty) = $opt'sw_e; # Discard leading digest only if empty 1035 local($watch) = $opt'sw_w; # Watch digest closely 1036 local($annotate) = $opt'sw_a; # Annotate items with X-Digest-To: field 1037 local(@leading); # Leading part of the digest 1038 local(@header); # Looked ahead header 1039 local($found_header) = 0; # True when header digest was found 1040 local($look_header) = 0; # True when we are looking for a mail header 1041 local($found_end) = 0; # True when end of digest found 1042 local($valid); # Return value from header checking package 1043 local($failed) = 0; # Queuing status for each mail item 1044 local(@body); # Body of extracted mail 1045 local($item) = 0; # Count digest items found 1046 local($not_rfc934) = 0; # Is digest RFC-934 compliant? 1047 local($digest_to); # Value of the X-Digest-To: field 1048 local($_); 1049 # If item annotation is requested, then each item will have a X-Digest-To: 1050 # field added, which lists both the To: and Cc: fields of the original 1051 # digest message. 1052 if ($annotate) { # Annotation requested 1053 $digest_to = $Header{'Cc'}; 1054 $digest_to = ', ' . $digest_to if $digest_to; 1055 $digest_to = 'X-Digest-To: ' . $Header{'To'} . $digest_to; 1056 $digest_to = &header'format($digest_to); 1057 } 1058 # Start digest parsing. According to RFC-934, we could only look for a 1059 # single '-' as encapsulation boundary, but for safety we look for at least 1060 # three consecutive ones. 1061 foreach (split(/\n/, $Header{'All'})) { 1062 push(@leading, $_) unless $found_header; 1063 push(@body, $_) if $found_header; 1064 if (/^---/) { # Start looking for mail header 1065 $look_header = 1; # Focus on mail headers now 1066 # We are withing the body of a digest and we've just reached 1067 # what may be the end of a message, or the end of the leading part. 1068 @header = (); # Reset look ahead buffer 1069 &header'reset; # Reset header checking package 1070 next; 1071 } 1072 next unless $look_header; 1073 # Record lines we find, but skip possible blank lines after dash. 1074 # Note that RFC-934 does not make spaces compulsory after each 1075 # encapsulation boundary (EB) but they are allowed nonetheless. 1076 next if /^\s*$/ && 0 == @header; 1077 $found_end = 0; # Maybe it's not garbage after all... 1078 $valid = &header'valid($_); 1079 if ($valid == 0) { # Not a valid header 1080 $look_header = 0; # False alert 1081 $found_end = 1; # Garbage after last EB is to be ignored 1082 if ($watch) { 1083 # Strict RFC-934: if an EB is followed by something which does 1084 # not prove to be a valid header but looked like one, enough 1085 # to have some lines collected into @header, then signal it. 1086 ++$not_rfc934 unless 0 == @header; 1087 } else { 1088 # Don't be too scrict. If what we have found so far *may be* a 1089 # header, then yes, it's not RFC-934. Otherwise let it go. 1090 ++$not_rfc934 if $header'maybe; 1091 } 1092 next; 1093 } elsif ($valid == 1) { # Still in header 1094 push(@header, $_); # Record header lines 1095 next; 1096 } 1097 # Coming here means we reached the end of a valid header 1098 push(@header, $digest_to) if $annotate; 1099 push(@header, ''); # Blank header line 1100 if (!$found_header) { 1101 if ($empty) { 1102 $failed |= &save_mail(*leading, $folder) 1103 unless &empty_body(*leading) || $discard; 1104 } else { 1105 $failed |= &save_mail(*leading, $folder) unless $discard; 1106 } 1107 undef @leading; # Not needed any longer 1108 $item++; # So that 'save_mail' starts logging items 1109 } 1110 # If there was already a mail being collected, save it now, because 1111 # we are sure it is followed by a valid mail. 1112 $failed |= &save_mail(*body, $folder) if $found_header; 1113 $found_header = 1; # End of header -> this is truly a digest 1114 $look_header = 0; # We found our header 1115 &header'clean(*header); # Ensure minimal set of header 1116 @body = @header; # Copy headers in mail body for next message 1117 } 1118 1119 return -1 unless $found_header; # Message was not in digest format 1120 1121 # Save last message, making sure to add a final dash line if digest did 1122 # not have one: There was one if $look_header is true. There was also 1123 # one if $found_end is true. 1124 push(@body, '---') unless $look_header || $found_end; 1125 1126 # If the -w option was used, we look closely at the supposed trailing 1127 # garbage. If the length is greater than 100 characters, then maybe we 1128 # are missing something here... 1129 if ($watch) { 1130 local($idx) = $#body; 1131 $_ = $body[$idx]; # Get last line 1132 @header = (); # Reset "garbage collector" 1133 unless (/^---/) { # Do not go on if end of digest truly found 1134 for (; $idx >= 0; $idx--) { 1135 $_ = $body[$idx]; 1136 last if /^---/; # Reached end of presumed trailing garbage 1137 unshift(@header, $_); 1138 } 1139 } 1140 } 1141 1142 # Now save last message 1143 $failed |= &save_mail(*body, $folder); 1144 1145 # If we collected something into @header and if it is big enough, save it 1146 # as a trailing message. 1147 if ($watch && length(join('', @header)) > 100) { 1148 &add_log("NOTICE [$mfile] has trailing garbage...") if $loglvl > 6; 1149 @body = @header; # Copy saved garbage 1150 @header = (); # Now build final garbage headers 1151 $header[0] = 'Subject: ' . $Header{'Subject'} . ' (trailing garbage)'; 1152 $header[1] = $digest_to if $annotate; 1153 &header'clean(*header); # Build other headers 1154 unshift(@body, '') unless $body[0] =~ s/^\s*$//; # Ensure EOH 1155 foreach (@body) { 1156 push(@header, $_); 1157 } 1158 push(@header, '---'); 1159 $failed |= &save_mail(*header, $folder); 1160 } 1161 1162 $failed + 0x2 * $inplace + 0x4 * ($folder =~ /^\s*$/) 1163 + 0x8 * ($not_rfc934 > 0); 1164} 1165 1166# The "RUN" command and its friends 1167# Start a shell command and mail any output back to the user. The program is 1168# invoked from within the home directory. 1169sub shell_command { 1170 local($program, $input, $feedback) = @_; 1171 unless (chdir $cf'home) { 1172 &add_log("WARNING cannot chdir to $cf'home: $!") if $loglvl > 5; 1173 } 1174 $program =~ s/^\s*~/$cf'home/; # ~ substitution 1175 $program =~ s/\b~/$cf'home/g; # ~ substitution as first letter in word 1176 $SIG{'PIPE'} = 'popen_failed'; # Protect against naughty program 1177 $SIG{'ALRM'} = 'alarm_clock'; # Protect against loops 1178 alarm $cf'runmax; # At most that amount of processing 1179 eval '&execute_command($program, $input, $feedback)'; 1180 alarm 0; # Disable alarm timeout 1181 $SIG{'PIPE'} = 'emergency'; # Restore initial value 1182 $SIG{'ALRM'} = 'DEFAULT'; # Restore default behaviour 1183 local($msg) = $@; 1184 $@ = ''; # Clear this global for our caller 1185 if ($msg =~ /^failed/) { # Something went wrong? 1186 &add_log("ERROR couldn't run '$program'") if $loglvl > 0; 1187 return 1; # Failed 1188 } elsif ($msg =~ /^aborted/) { # Writing to program failed 1189 &add_log("WARNING pipe closed by '$program'") if $loglvl > 5; 1190 return 1; # Failed 1191 } elsif ($msg =~ /^feedback/) { # Feedback failed 1192 &add_log("WARNING no feedback occurred") if $loglvl > 5; 1193 return 1; # Failed 1194 } elsif ($msg =~ /^alarm/) { # Timeout 1195 &add_log("WARNING time out received ($cf'runmax seconds)") 1196 if $loglvl > 5; 1197 return 1; # Failed 1198 } elsif ($msg =~ /^non-zero/) { # Program returned non-zero status 1199 &add_log("WARNING program returned non-zero status") if $loglvl > 5; 1200 return 1; 1201 } elsif ($msg) { 1202 $msg =~ s/\n$//; # Not sure it's there... don't chop! 1203 &add_log("ERROR $msg") if $loglvl > 0; 1204 return 1; # Failed 1205 } 1206 0; # Everything went fine 1207} 1208 1209# Abort execution of command when popen() fails or program dies abruptly 1210sub popen_failed { 1211 local($status) = 'died abruptly'; # Status for &mail_back 1212 &mail_back; # Let the user know about a possible error message 1213 unlink "$trace" if -f "$trace"; 1214 die "$error\n"; 1215} 1216 1217# When an alarm call is received, we should be in the 'execute_command' 1218# routine. The $pid variable holds the pid number of the process to be killed. 1219sub alarm_clock { 1220 if ($trace ne '' && -f "$trace") { # We come from execute_command 1221 local($status) = "terminated"; # Process was terminated 1222 if (kill "SIGTERM", $pid) { # We could signal our child 1223 sleep 30; # Give child time to die 1224 unless (kill "SIGTERM", $pid) { # Child did not die yet ? 1225 unless (kill "SIGKILL", $pid) { 1226 &add_log("ERROR could not kill process $pid: $!") 1227 if $loglvl > 1; 1228 } else { 1229 $status = "killed"; 1230 &add_log("KILLED process $pid") if $loglvl > 4; 1231 } 1232 } else { 1233 &add_log("TERMINATED process $pid") if $loglvl > 4; 1234 } 1235 } else { 1236 $status = "unknown"; # Process died ? 1237 &add_log("ERROR coud not signal process $pid: $!") 1238 if $loglvl > 1; 1239 } 1240 &mail_back; # Mail back any output we have so far 1241 unlink "$trace"; # Remove output of command 1242 } 1243 die "alarm call\n"; # Longjmp to shell_command 1244} 1245 1246# Print whole mail to supplied fd, without any Content-Transfer-Encoding. 1247sub print_binary_mail { 1248 my ($fd) = @_; 1249 my $skip = 0; 1250 foreach my $line (split(/\n/, $Header{'Head'})) { 1251 if ($line =~ /^\s/) { 1252 print $fd $line, "\n" unless $skip; 1253 } else { 1254 $skip = 0; 1255 my ($field) = $line =~ /^([\w-]+):/; 1256 $skip = lc($field) eq "content-transfer-encoding"; 1257 print $fd $line, "\n" unless $skip; 1258 } 1259 } 1260 print $fd "\n"; 1261 print $fd ${$Header{'=Body='}}; # No content transfer-encoding 1262} 1263 1264# Execute the command, ran in an eval to protect against SIGPIPE signals 1265sub execute_command { 1266 local($program, $input, $feedback) = @_; 1267 1268 local($location) = &locate_program($program); 1269 die "can't locate $location in PATH\n" unless $location =~ m|/|; 1270 die "unsecure $location\n" unless &exec_secure($location); 1271 1272 local($trace) = "$cf'tmpdir/trace.run$$"; # Where output goes 1273 local($error) = "failed"; # Error reported by popen_failed 1274 pipe(READ, WRITE); # Open a pipe 1275 local($pid) = fork; # We fork here 1276 $pid = -1 unless defined $pid; 1277 1278 if ($pid == 0) { # Child process 1279 alarm 0; 1280 close WRITE; # The child reads from pipe 1281 open(STDIN, "<&READ"); # Redirect stdin to pipe 1282 close READ if $input == $NO_INPUT; # Close stdin if needed 1283 unless (open(STDOUT, ">$trace")) { # Where output goes 1284 &add_log("WARNING couldn't create $trace: $!") if $loglvl > 5; 1285 if ($feedback != $NO_FEEDBACK) { # Need trace if feedback 1286 kill 'SIGPIPE', getppid; # Parent still waiting 1287 exit 1; 1288 } 1289 } 1290 open(STDERR, ">&STDOUT"); # Make it follow pipe 1291 # Using a sub-block ensures exec() is followed by nothing 1292 # and makes mailagent "perl -cw" clean, whatever that means ;-) 1293 { exec $program } # Run the program now 1294 &add_log("ERROR couldn't exec '$program': $!") if $loglvl > 1; 1295 exit 1; 1296 } elsif ($pid == -1) { 1297 &add_log("ERROR couldn't fork: $!") if $loglvl; 1298 return; 1299 } 1300 1301 close READ; # The parent writes to its child 1302 $error = "aborted"; # Error reported by popen_failed 1303 select(WRITE); 1304 $| = 1; # Hot pipe wanted 1305 select(STDOUT); 1306 1307 # Now feed the program with the mail 1308 if ($input == $BODY_INPUT) { # Pipes *decoded* body 1309 print WRITE ${$Header{'=Body='}}; 1310 } elsif ($input == $MAIL_INPUT) { # Pipes the whole mail 1311 print WRITE $Header{'All'}; 1312 } elsif ($input == $MAIL_INPUT_BINARY) { # Remove any transfer encoding 1313 print_binary_mail(\*WRITE); 1314 } elsif ($input == $HEADER_INPUT) { # Pipes the header 1315 print WRITE $Header{'Head'}; 1316 } 1317 close WRITE; # Close input, before waiting! 1318 1319 wait(); # Wait for our child 1320 local($status) = $? ? "failed" : "ok"; 1321 if ($?) { 1322 # Log execution failure and return to shell_command via die if some 1323 # feedback was to be done. 1324 &add_log("ERROR execution failed for '$program'") if $loglvl > 1; 1325 if ($feedback != $NO_FEEDBACK) { # We wanted feedback 1326 &mail_back; # Mail back any output 1327 unlink "$trace"; # Remove output of command 1328 die "feedback\n"; # Longjmp to shell_command 1329 } 1330 } 1331 1332 &handle_output; # Take appropriate action with command output 1333 unlink "$trace"; # Remove output of command 1334 die "non-zero status\n" unless $status eq 'ok'; 1335} 1336 1337# If no feedback is wanted, simply mail the output of the commands to the 1338# user. However, in case of feedback, we have to update the values of 1339# %Header in the entries 'All', 'Body' and 'Head'. Note that the other 1340# header fields are left untouched. Only a RESYNC can synchronize them 1341# (this makes sense only for a FEED command, of course). 1342# Uses $feedback from execute_command 1343sub handle_output { 1344 if ($feedback == $NO_FEEDBACK) { 1345 &mail_back; # Mail back any output 1346 } else { 1347 &feed_back($feedback); # Feed result back into %Header 1348 } 1349} 1350 1351# Mail back the contents of the trace file (output of program), if not empty. 1352# Uses some local variables from execute_command 1353sub mail_back { 1354 local($size) = -s "$trace"; # Size of output 1355 return unless $size; # Nothing to be done if no output 1356 local($std_input); # Standard input used 1357 $std_input = "none" if $input == $NO_INPUT; 1358 $std_input = "mail body" if $input == $BODY_INPUT; 1359 $std_input = "whole mail" if $input == $MAIL_INPUT; 1360 $std_input = "header" if $input == $HEADER_INPUT; 1361 local($program_name) = $program =~ m|^(\S+)|; 1362 unless (open(MAILER,"|$cf'sendmail $cf'mailopt $cf'email")) { 1363 &add_log("SYSERR fork: $!") if $loglvl; 1364 } 1365 print MAILER <<EOM; 1366To: $cf'email 1367Subject: Output of your '$program_name' command ($status) 1368$MAILER 1369 1370Your command was: $program 1371Input: $std_input 1372Status: $status 1373 1374It produced the following output: 1375 1376EOM 1377 unless (open(TRACE, "$trace")) { 1378 &add_log("ERROR couldn't reopen $trace") if $loglvl > 1; 1379 print MAILER "*** SORRY -- NOT AVAILABLE ***\n"; 1380 } else { 1381 while (<TRACE>) { 1382 print MAILER; 1383 } 1384 close TRACE; 1385 } 1386 close MAILER; 1387 unless ($?) { 1388 &add_log("SENT output of '$program_name' to $cf'email ($size bytes)") 1389 if $loglvl > 2; 1390 } else { 1391 &add_log("ERROR couldn't send $size bytes to $cf'email") if $loglvl; 1392 &trace_dump($trace, "$program_name output ($status)"); 1393 } 1394} 1395 1396# Feed back output of a command in the %Header data structure. 1397# Uses some local variables from execute_command 1398sub feed_back { 1399 my ($feedback) = @_; 1400 unless (open(TRACE, "$trace")) { 1401 &add_log("ERROR couldn't feed back from $trace: $!") if $loglvl > 1; 1402 unlink "$trace"; # Maybe I should leave it around 1403 die "feedback\n"; # Return to shell_command 1404 } 1405 local($temp) = ' ' x 2000; # Temporary storage (pre-extended) 1406 $temp = ''; 1407 local($last_was_nl) = 1; # True when previous line was blank 1408 if ($input == $BODY_INPUT) { # We have to feed back the body only 1409 while (<TRACE>) { 1410 # Protect potentially dangerous lines. If fromall is ON, then we 1411 # don't care whether From is within a paragraph, i.e. not preceded 1412 # by a blank line. This is only required with "broken" User Agents. 1413 s/^From(\s)/>From$1/ if $last_was_nl && $cf'fromesc =~ /on/i; 1414 $last_was_nl = /^$/ || $cf'fromall =~ /on/i; 1415 $temp .= $_; 1416 } 1417 } else { 1418 local($head) = ' ' x 500; # Pre-extend header 1419 $head = ''; 1420 while (<TRACE>) { 1421 if (1../^$/) { 1422 $head .= $_ unless /^$/; 1423 } else { 1424 # Protect potentially dangerous lines 1425 s/^From(\s)/>From$1/ if $last_was_nl && $cf'fromesc =~ /on/i; 1426 $last_was_nl = /^$/ || $cf'fromall =~ /on/i; 1427 $temp .= $_; 1428 } 1429 } 1430 if ($head =~ /^\s*$/s) { # A perl5 construct 1431 &add_log("ERROR got empty header from $trace") if $loglvl > 1; 1432 unlink "$trace"; # Maybe I should leave it around 1433 die "feedback\n"; # Return to shell_command 1434 } 1435 $Header{'Head'} = $head; 1436 } 1437 close TRACE; 1438 $Header{'Body'} = $temp unless $input == $HEADER_INPUT; 1439 $Header{'All'} = $Header{'Head'} . "\n" . $Header{'Body'}; 1440 if ($input == $BODY_INPUT) { 1441 # Was fed *decoded* body, got a decoded body back. 1442 # Headers have not changed, recoding will happen as in the original 1443 &body_recode; 1444 } elsif ($input == $MAIL_INPUT) { 1445 # Headers could have changed and we need to reparse them in order 1446 # to know how/whether we should decode the body. 1447 &header_resync; 1448 &body_check; # Update $Header{'=Body='} to point to *decoded* body 1449 if ($feedback == $FEEDBACK_ENCODING) { 1450 &header_resync if &body_recode_optimally; 1451 } 1452 } elsif ($input == $HEADER_INPUT) { 1453 # Headers pertaining to body encoding could have changed. 1454 &header_check_body_encoding; # Check and recode if possible 1455 &header_resync; # Resynchronize %Header 1456 } elsif ($input == $MAIL_INPUT_BINARY) { 1457 # Was fed a *decoded* body, got at possibly decoded body back. 1458 my $old_encoding = lc($Header{'Content-Transfer-Encoding'}); 1459 &header_resync; 1460 &body_check; # Update $Header{'=Body='} to point to *decoded* body 1461 if ($feedback == $FEEDBACK_ENCODING) { 1462 # Scan the decoded body and determine the optimal content 1463 # transfer encoding, recoding the body as needed and updating 1464 # the headers should they change. 1465 &header_resync if &body_recode_optimally; 1466 } else { 1467 # Adjust encoding if needed (they did not supply the -e to FEED) 1468 my $current_encoding = lc($Header{'Content-Transfer-Encoding'}); 1469 my %encoded = map { $_ => 1 } qw(base64 quoted-printable); 1470 # We need to recode if there is presently no encoding but there was 1471 # one originally. They could have properly re-encoded the body, 1472 # which is why we have to check for the current encoding. 1473 if (!$encoded{$current_encoding} && $encoded{$old_encoding}) { 1474 alter_header("Content-Transfer-Encoding", $HD_STRIP); 1475 header_append(header'format( 1476 "Content-Transfer-Encoding: $old_encoding\n")); 1477 body_recode_with($old_encoding); 1478 } 1479 } 1480 } else { 1481 &add_log("ERROR BUG in feed_back: unknown input value \"$input\""); 1482 } 1483} 1484 1485# Feed output back into $Back variable (used by BACK command). Typically, the 1486# BACK command is used with RUN, though any other command is allowed (but does 1487# not always make sense). 1488# NB: This routine: 1489# - Is never called explicitely but via a type glob through *handle_output 1490# - Uses some local variables from execute_command 1491sub xeq_back { 1492 unless (open(TRACE, "$trace")) { 1493 &add_log("ERROR couldn't feed back from $trace: $!") if $loglvl > 1; 1494 unlink "$trace"; # Maybe I should leave it around 1495 die "feedback\n"; # Return to shell_command 1496 } 1497 while (<TRACE>) { 1498 chop; 1499 next if /^\s*$/; 1500 $Back .= $_ . '; '; # Replace \n by ';' separator 1501 } 1502 close TRACE; 1503} 1504 1505# The "RESYNC" command 1506# Resynchronizes the %Header entries by reparsing the 'Head' entry 1507sub header_resync { 1508 # Clean up all the non-special entries 1509 foreach $key (keys %Header) { 1510 next if $Pseudokey{$key}; # Skip pseudo-header entries 1511 delete $Header{$key}; 1512 } 1513 my $first_from = header_parse($Header{'Head'}, \%Header, 0); 1514 &header_check($first_from, undef); # Sanity checks 1515} 1516 1517# The "STRIP" and "KEEP" commands (case insensitive) 1518# Removes or keeps some headers and update the Header structure 1519sub alter_header { 1520 local($headers, $action) = @_; 1521 $headers = 1522 &complete_list($headers, 'header'); # Process "file-inclusion" 1523 local(@list) = split(/\s/, $headers); 1524 local(@head) = split(/\n/, $Header{'Head'}); 1525 local(@newhead); # The constructed header 1526 local($last_was_altered) = 0; # Set to true when header is altered 1527 local($matched); # Did any header matched ? 1528 local($line); # Original header line 1529 1530 foreach $h (@list) { # Prepare patterns 1531 $h =~ s/:$//; # Remove trailing ':' if any 1532 $h = &perl_pattern($h); # Headers specified by shell patterns 1533 } 1534 1535 foreach (@head) { 1536 if (/^From\s/) { # First From line... 1537 push(@newhead, $_); # Keep it anyway 1538 next; 1539 } 1540 $line = $_; # Save original 1541 # Make sure header field name is normalized before attempting a match 1542 s/^([!-9;-~\w-]+):/&header'normalize($1).':'/e; 1543 unless (/^\s/) { # If not a continuation line 1544 $last_was_altered = 0; # Reset header alteration flag 1545 $matched = 0; # Assume no match 1546 foreach $h (@list) { # Loop over to-be-altered lines 1547 if (/^$h:/i) { # We found a line to be removed/kept 1548 $matched = 1; 1549 last; 1550 } 1551 } 1552 $last_was_altered = $matched; 1553 next if $matched && $action == $HD_SKIP; 1554 next if !$matched && $action == $HD_KEEP; 1555 } 1556 if ($action == $HD_SKIP) { 1557 next if /^\s/ && $last_was_altered; # Skip header continuations 1558 } else { # Action is $HD_KEEP 1559 next if /^\s/ && !$last_was_altered; # Header was not kept 1560 } 1561 push(@newhead, $line); # Add line to the new header 1562 } 1563 $Header{'Head'} = join("\n", @newhead) . "\n"; 1564 $Header{'All'} = $Header{'Head'} . "\n" . $Header{'Body'}; 1565 1566 # Headers pertaining to body encoding could have changed. 1567 &header_check_body_encoding; # Check, but no resync 1568} 1569 1570# The "ANNOTATE" command 1571sub annotate_header { 1572 local($field, $value) = @_; # Field, value 1573 if ($opt'sw_u) { # -u means "unique": no anno if present 1574 local($normalized) = &header'normalize($field); 1575 return 1 if defined $Header{$normalized} && $Header{$normalized} ne ''; 1576 } 1577 if ($value eq '' && $opt'sw_d) { # No date and no value for field! 1578 &add_log("WARNING no value for '$field' annotation") if $loglvl > 5; 1579 return 1; 1580 } 1581 if ($field eq '') { # No field specified! 1582 &add_log("WARNING no field specified for annotation") if $loglvl > 5; 1583 return 1; 1584 } 1585 local($annotation) = ''; # Annotation made 1586 $annotation = "$field: " . &header'mta_date() . "\n" unless $opt'sw_d; 1587 $annotation .= &header'format("$field: $value") . "\n" if $value ne ''; 1588 &header_append($annotation); # Add field into %Header 1589 0; 1590} 1591 1592 1593# Utilitity routine for alter_field() 1594# Performs $op on $bufref, the value of the header field $header, and insert 1595# result in the head (pointed to by $headref), or the original raw buffer if 1596# there was no change. 1597# Returns whether there was a change or not, undef on eval() error. 1598sub runop_on_field { 1599 my ($header, $op, $bufref, $raw_bufref, $headref) = @_; 1600 1601 &add_log("running $op for $header: " . $$bufref) if $loglvl > 19; 1602 my $changed = eval "\$\$bufref =~ $op"; 1603 if ($@) { 1604 &add_log("ERROR operation $op failed: $@") if $loglvl > 1; 1605 return undef; # Abort further processing 1606 } 1607 &add_log("changed buffer: " . $$bufref) if $changed && $loglvl > 19; 1608 $$headref .= $changed ? 1609 &header'format("$header: " . $$bufref) : 1610 ("$header: " . $$raw_bufref); 1611 $$headref .= "\n"; 1612 1613 return $changed ? 1 : 0; 1614} 1615 1616# The "TR" and "SUBST" commands targetted to header field. 1617# The operation (s/// or tr//) is performed on the header field. 1618# If a match occurrs, the whole header is reformatted. 1619# Returns failure status (0 means OK) 1620sub alter_field { 1621 my ($header_field, $op) = @_; 1622 $header_field = &header'normalize($header_field); 1623 1624 my $head = ' ' x length $Header{'Head'}; 1625 $head = ''; 1626 my $last_header = ''; # Non-empty indicates header field to process 1627 my $buffer; # Holds value of field to process 1628 my $raw_buffer; # Holds raw lines of field to process 1629 my $ever_changed = 0; 1630 1631 foreach (split(/\n/, $Header{'Head'})) { 1632 if (/^\s/) { 1633 if ($last_header eq '') { 1634 $head .= $_ . "\n"; 1635 } else { 1636 $raw_buffer .= "\n$_"; # In case there's no change 1637 s/^\s+/ /; 1638 $buffer .= $_; # What we'll run $op on 1639 } 1640 } elsif (my ($field, $value) = /^([\w-]+)\s*:\s*(.*)/) { 1641 1642 # Perform operation on $buffer if previous header matched. 1643 if ($last_header ne '') { 1644 my $changed = runop_on_field($last_header, $op, 1645 \$buffer, \$raw_buffer, \$head); 1646 return 1 unless defined $changed; # Abort, because $op failed 1647 $ever_changed++ if $changed; 1648 $last_header = ''; 1649 } 1650 1651 if (&header'normalize($field) eq $header_field) { 1652 $last_header = $field; # Indicates a match 1653 $raw_buffer = $buffer = $value; 1654 } else { 1655 $head .= $_ . "\n"; 1656 } 1657 } else { 1658 $head .= $_ . "\n"; 1659 } 1660 } 1661 1662 # Perform operation on $buffer if last header seen matched. 1663 if ($last_header ne '') { 1664 my $changed = runop_on_field($last_header, $op, 1665 \$buffer, \$raw_buffer, \$head); 1666 return 1 unless defined $changed; # Abort, because $op failed 1667 $ever_changed++ if $changed; 1668 } 1669 1670 # Resynchronize pseudo-headers if there was any change 1671 if ($ever_changed) { 1672 $Header{'All'} = $head . "\n" . $Header{'Body'}; 1673 $Header{'Head'} = $head; 1674 } 1675 1676 &add_log("changed $ever_changed $header_field line" . 1677 ($ever_changed == 1 ? '' : 's') . " with $op") if $loglvl > 6; 1678} 1679 1680# The "TR" and "SUBST" commands -- main entry point 1681sub alter_value { 1682 local($variable, $op) = @_; # Variable and operation to performed 1683 local($lvalue); # Perl variable to be modified 1684 local($extern); # Lvalue used for persistent variables 1685 1686 # We may modify a variable or a backreference (not read-only as in perl) 1687 if ($variable =~ s/^#://) { 1688 $extern = &extern'val($variable); # Fetch external value 1689 $lvalue = '$extern'; # Modify this variable 1690 } elsif ($variable =~ s/^#//) { 1691 $lvalue = '$Variable{\''.$variable.'\'}'; 1692 } elsif ($variable =~ /^\d\d?$/) { 1693 $variable = int($variable) - 1; 1694 $lvalue = '$Backref[' . $variable . ']'; 1695 } elsif ($variable =~ /^([\w-]+):?$/) { 1696 my $field = $1; # Dataloading will change $1 1697 return alter_field($field, $op); # More complex, handle separately 1698 } else { 1699 &add_log("ERROR incorrect variable name '$variable'") if $loglvl > 1; 1700 return 1; 1701 } 1702 1703 # Let perl do the work 1704 &add_log("running $lvalue =~ $op") if $loglvl > 19; 1705 eval $lvalue . " =~ $op"; 1706 &add_log("ERROR operation $op failed: $@") if $@ && $loglvl > 1; 1707 1708 # If an external (persistent) variable was used, update its value now, 1709 # unless the operation failed, in which case the value is not modified. 1710 &extern'set($variable, $extern) if $@ eq '' && $lvalue eq '$extern'; 1711 1712 $@ eq '' ? 0 : 1; # Failure status 1713} 1714 1715# The "PERL" command 1716sub perl { 1717 local($script) = @_; # Location of perl script 1718 local($failed) = ''; # Assume script did not fail 1719 local(@_); # No visible args for functions in script 1720 1721 unless (chdir $cf'home) { 1722 &add_log("WARNING cannot chdir to $cf'home: $!") if $loglvl > 5; 1723 } 1724 1725 $script =~ s/^\s*~/$cf'home/; # ~ substitution 1726 $script =~ s/\b~/$cf'home/g; # ~ substitution as first letter in word 1727 1728 # Set up the @ARGV array, by parsing the $script variable with &shellwords. 1729 # Note that the @ARGV array is held in the main package, but since the 1730 # mailagent makes no use of it at this point, there is no need to save its 1731 # value before clobbering it. 1732 1733 require Text::ParseWords; 1734 *shellwords = \&Text::ParseWords::old_shellwords; 1735 1736 eval '@ARGV = &shellwords($script)'; 1737 if (chop($@)) { # There was an unmatched quote 1738 $@ =~ s/^U/u/; 1739 &add_log("ERROR $@") if $loglvl > 1; 1740 &add_log("ERROR cannot run PERL $script") if $loglvl > 2; 1741 return 1; 1742 } 1743 1744 unless (open(PERL, $ARGV[0])) { 1745 &add_log("ERROR cannot open perl script $ARGV[0]: $!") if $loglvl > 1; 1746 return 1; 1747 } 1748 1749 # Fetch the perl script in memory, within a block to really localize $/ 1750 local($body) = ' ' x (-s PERL); 1751 { 1752 local($/) = undef; 1753 $body = <PERL>; # Slurp whole file into pre-extended variable 1754 } 1755 close(PERL); 1756 local(@saved) = @INC; # Save INC array (perl library location path) 1757 local(%saved) = %INC; # Save already required files 1758 1759 # Run the perl script in special package 1760 unshift(@INC, $privlib); # Files first searched for in mailagent's lib 1761 package mailhook; # -- entering in mailhook -- 1762 &interface'new; # Signal new script being loaded 1763 &hook'initvar('mailhook'); # Initialize convenience variables 1764 eval $'body; # Load, compile and execute within mailhook 1765 local($saved) = $@; # If perl5, interface::reset will use an eval! 1766 &interface'reset; # Clear the mailhook package if no more pending 1767 $@ = $saved; # Restore old $@ (useful only for perl5) 1768 package main; # -- reverting to main -- 1769 @INC = @saved; # Restore INC array 1770 %INC = %saved; # In case script has required some other files 1771 1772 # If the script died with an 'OK' error message, then it meant 'exit 0' 1773 # but also wanted the exit to be trapped. The &exit function is provided 1774 # for that purpose. 1775 if (chop($@)) { 1776 if ($@ =~ /^OK/) { 1777 $@ = ''; 1778 &add_log("script exited with status 0") if $loglvl > 18; 1779 } 1780 elsif ($@ =~ /^Exit (\d+)/) { 1781 $@ = ''; 1782 $failed = "exited with status $1"; 1783 } 1784 elsif ($@ =~ /^Status (\d+)/) { # A REJECT, RESTART or ABORT 1785 $@ = ''; 1786 $cont = $1; # This will modify control flow 1787 &add_log("script ended with a control '$cont'") if $loglvl > 18; 1788 } 1789 else { 1790 $@ =~ s/ in file \(eval\)//; 1791 &add_log("ERROR $@") if $loglvl; 1792 $failed = "execution aborted"; 1793 } 1794 &add_log("ERROR perl failed ($failed)") if $loglvl > 1 && $failed; 1795 } 1796 $failed ? 1 : 0; 1797} 1798 1799# The "REQUIRE" command 1800sub require { 1801 local($file, $package) = @_; # File to load, package to put it in 1802 $package = 'newcmd' if $package eq ''; # Use newcmd if no package 1803 $file =~ s/^\s*~/$cf'home/; # ~ substitution 1804 # Note that the dynload package records files being loaded into a H table, 1805 # and "requiring" two times the same file in the *same* package will be 1806 # a no-op, returning the same status as the first time. 1807 local($ok) = &dynload'load($package, $file); 1808 $file = &tilda($file); # Replace home directory with a nice ~ 1809 unless (defined $ok) { 1810 &add_log("ERROR cannot load $file in package $package"); 1811 return 1; # Require failed 1812 } 1813 unless ($ok) { 1814 &add_log("ERROR cannot parse $file into package $package"); 1815 return 1; # Require failed 1816 } 1817 0; # Success 1818} 1819 1820# The "DO" command 1821# The routine name can be one of pack'routine, COMMAND:pack'routine or 1822# /some/path:pack'routine. The following parsing duplicates the one done 1823# in &dynload'do, so beware, should the interface change. 1824sub do { 1825 local($something, $routine, $args) = @_; 1826 $routine = $what if $something eq ''; 1827 unless (&dynload'do($what)) { 1828 local($under); 1829 $under = " under $something" if $something ne ''; 1830 &add_log("ERROR couldn't locate routine $routine$under") if $loglvl > 1; 1831 return 1; # Failed 1832 } 1833 $args = '()' unless $args; 1834 &add_log("calling routine $routine$args") if $loglvl > 15; 1835 eval "package main; &$routine$args;"; 1836 1837 # I want to allow people to call mailhook commands from a DO routine call. 1838 # However, commands modifying the filtering control flow are performing a 1839 # die() with 'Status x' as the error message where 'x' defines the new 1840 # continuation value for run_command. This is trapped specially here. 1841 # Note however that convenience variables typically set for PERL escapes 1842 # are not available via a DO. 1843 1844 if (chop($@)) { 1845 local($_) = $@; 1846 $@ = ''; # Avoid cascades: we're within an eval already 1847 if (/^Status (\d+)$/) { # Filter automaton continuation status 1848 $cont = $1; # Propagate status ($cont from &run_command) 1849 &add_log("NOTICE $routine shifted automaton to status $cont") 1850 if $loglvl > 1; 1851 } else { 1852 &add_log("ERROR cannot call $routine$args: $_") if $loglvl > 1; 1853 return 1; 1854 } 1855 } 1856 0; # Success 1857} 1858 1859# The "AFTER" command 1860sub after { 1861 local($time, $action) = @_; 1862 local($no_input) = $opt'sw_n; 1863 local($shell_cmd) = $opt'sw_s; 1864 local($agent_cmd) = $opt'sw_a || !($opt'sw_n || $opt'sw_s || $opt'sw_c); 1865 local($now) = time; # Current time 1866 local($start); # Action's starting time 1867 $start = &getdate($time, $now); 1868 if ($start == -1) { 1869 &add_log("ERROR in AFTER: time '$time' is incorrect") if $loglvl > 1; 1870 return (1,undef); 1871 } 1872 if ($start < $now) { 1873 &add_log("NOTICE time '$time' ($start) is before now ($now)") 1874 if $loglvl > 5; 1875 &add_log("ERROR in AFTER: command should have run already!") 1876 if $loglvl > 1; 1877 return (1,undef); 1878 } 1879 local($atype) = $agent_cmd ? $callout'AGENT : 1880 ($shell_cmd ? $callout'SHELL : $callout'CMD); 1881 local($qfile) = &callout'queue($start, $action, $atype, $no_input); 1882 unless (defined $qfile) { 1883 &add_log("ERROR in AFTER: cannot queue action $action") if $loglvl > 1; 1884 return (1,undef); 1885 } 1886 (0, $qfile); # Success 1887} 1888 1889# Modify control flow within automaton by calling a non-existant function 1890# &perform, which has been dynamically bound to one of the do_* functions. 1891# The REJECT, RESTART and ABORT actions share the following options and 1892# arguments. If followed by -t (resp. -f), then the action only takes place 1893# when the last recorded command status is true (resp. false, i.e. failure). 1894# If a mode is present as an argument, the the state of the automaton is 1895# changed to that mode prior alteration of the control flow. 1896sub alter_flow { 1897 local($mode) = @_; # New mode we eventually change to 1898 &add_log("last cmd status is $lastcmd") if $loglvl > 11; 1899 # Variable $lastcmd comes from xeqte(), $wmode comes from analyze_mail(). 1900 return 0 if $opt'sw_t && $lastcmd != 0; 1901 return 0 if $opt'sw_f && $lastcmd == 0; 1902 if ($mode ne '') { 1903 &add_log("entering new state $mode") if $loglvl > 6 && $mode ne $wmode; 1904 $wmode = $mode; 1905 } 1906 &perform; # This was dynamically bound 1907} 1908 1909# Perform a "REJECT" 1910sub do_reject { 1911 $cont = $FT_REJECT; # Reject ($cont defined in run_command) 1912 &add_log("REJECTED [$mfile] in state $wmode") if $loglvl > 4; 1913 0; 1914} 1915 1916# Perform a "RESTART" 1917sub do_restart { 1918 $cont = $FT_RESTART; # Restart ($cont defined in run_command) 1919 &add_log("RESTARTED [$mfile] in state $wmode") if $loglvl > 4; 1920 0; 1921} 1922 1923# Perform an "ABORT" 1924sub do_abort { 1925 $cont = $FT_ABORT; # Abort filtering ($cont defined in run_command) 1926 &add_log("ABORTED [$mfile] in state $wmode") if $loglvl > 4; 1927 0; 1928} 1929 1930# Given a list of items separated by white spaces, return a new list of 1931# items, but with "include-request" processed. 1932sub complete_list { 1933 local(@addr) = split(' ', $_[0]); # Original list 1934 local($type) = $_[1]; # Type of item (header, address, ...) 1935 local(@result); # Where result list is built 1936 local($filename); # Name of include file 1937 local($_); 1938 foreach $addr (@addr) { 1939 if ($addr !~ /^"/) { # Item not enclosed within "" 1940 push(@result, $addr); # Kept as-is 1941 } else { 1942 # Load items from file whose name is given between "quotes" 1943 push(@result, &include_file($addr, $type)); 1944 } 1945 } 1946 join(' ', @result); # Return space separated items 1947} 1948 1949# Save digest mail into a folder, or queue it if no folder is provided 1950# Uses the variable '$item' from 'split' to log items. 1951sub save_mail { 1952 local(*array, $folder) = @_; # Where mail is and where to put it 1953 local($length) = 0; # Length of the digest item 1954 local($mbox, $failed, $log_message); 1955 local($_); 1956 # Go back to the previous dash line, removing it from the body part 1957 # (it's only a separator). In the process, we also remove any looked ahead 1958 # header which belongs to the next digest item. 1959 do { 1960 $_ = pop(@array); # Remove what belongs to next digest item 1961 } while !/^---/; 1962 # It is recommended in RFC-934 that all leading EB be escaped by a leading 1963 # '- ' sequence, to allow nested forwarding. However, since the message 1964 # we are dealing with might not be RFC-934 compliant, we are only removing 1965 # the leading '- ' if it is followed by a '-'. We also use the loop to 1966 # escape all potentially dangerous From lines. 1967 local($last_was_space); 1968 foreach (@array) { 1969 # Protect potentially dangerous lines 1970 s/^From\s+(\S+)/>From $1/ if $last_was_space && $cf'fromesc =~ /on/i; 1971 s/^- -/-/; # This is the EB escape in RFC-934 1972 # From is dangerous after blank line, but everywhere if fromall is ON. 1973 $last_was_space = /^$/ || $cf'fromall =~ /on/i; 1974 } 1975 # Now @array holds the whole digest item 1976 if ($folder =~ /^\s*$/) { # No folder means we have to queue message 1977 local($name) = &qmail(*array); 1978 $failed = defined $name ? 0 : 1; 1979 $log_message = $name =~ m|/| ? "file [$name]" : "queue [$name]"; 1980 foreach (@array) { 1981 $length += length($_) + 1; # No trailing new-lines 1982 } 1983 } else { 1984 # Looks like we have to save the message in a folder. I cannot really 1985 # ask for a local variable named %Header because emergency routines 1986 # use it to save mail (they expect the whole mail in $Header{'All'}). 1987 # However, if something goes wrong, we'll get back to the filter main 1988 # loop and a LEAVE (default action) will be executed, taking the 1989 # current values from 'Head' and 'Body'. Hence the following: 1990 1991 local(%NHeader); 1992 $NHeader{'All'} = $Header{'All'}; 1993 local(*Header) = *NHeader; # From now on, we really work on %NHeader 1994 local($in_header) = 1; # True while in message header 1995 local($first_from); # First From line 1996 1997 # Fill in %Header strcuture, which is expected by save(): header in 1998 # entry 'Head' and body in entry 'Body'. 1999 foreach (@array) { 2000 if ($in_header) { 2001 $in_header = 0 if /^$/; 2002 next if /^$/; 2003 $Header{'Head'} .= $_ . "\n"; 2004 $first_from = $_ if /^From\s+\S+/; 2005 next; 2006 } 2007 $Header{'Body'} .= $_ . "\n"; 2008 } 2009 &header_prepend("$FAKE_FROM\n") unless $first_from; 2010 2011 # Now save into folder 2012 ($mbox, $failed, $log_message) = &run_saving($folder, $FOLDER_APPEND); 2013 2014 # Keep track in the logfile of the length of the digest item. 2015 $length = length($Header{'Head'}) + length($Header{'Body'}) + 1; 2016 } 2017 if ($failed) { 2018 if ($loglvl > 2) { 2019 local($s) = $length == 1 ? '' : 's'; 2020 &add_log("ERROR unable to save #$item ($length byte$s)") if $item; 2021 &add_log("ERROR unable to save preamble ($length byte$s)") 2022 unless $item; 2023 } 2024 } else { 2025 if ($loglvl > 7) { 2026 local($s) = $length == 1 ? '' : 's'; 2027 &add_log("SPLIT #$item in $log_message ($length byte$s)") if $item; 2028 &add_log("SPLIT preamble in $log_message ($length byte$s)") 2029 unless $item; 2030 } 2031 } 2032 ++$item if $item; # Count items, but not preamble (done by 'split') 2033 $failed; # Propagate failure status 2034} 2035 2036# Check body message (typically head of digest message) and return 1 if its 2037# body is empty, 0 otherwise. 2038sub empty_body { 2039 local(*ary) = @_; 2040 local(@array) = @ary; # Work on a copy 2041 local($_); 2042 local($is_empty) = 1; 2043 do { 2044 $_ = pop(@array); # Remove what belongs to next digest item 2045 } while !/^---/; 2046 do { 2047 $_ = shift(@array); # Remove the whole header 2048 } while !/^$/; 2049 foreach (@array) { 2050 $is_empty = 0 unless /^\s*$/; 2051 last unless $is_empty; 2052 } 2053 $is_empty; 2054} 2055 2056# Dump trace in ~/agent.trace 2057sub trace_dump { 2058 local($trace, $what) = @_; 2059 local($ok) = 1; 2060 open(DUMP, ">>$cf'home/agent.trace") || ($ok = 0); 2061 print DUMP "--- Trace for $what ---\n"; 2062 print DUMP "--- (was unable to mail it back) ---\n"; 2063 open(TRACE, $trace) || ($ok = 0); 2064 while (<TRACE>) { print DUMP; } 2065 print DUMP "--- End of trace for $what ---\n"; 2066 close DUMP; 2067 &add_log("DUMPED trace in ~/agent.trace") if $ok && $loglvl > 2; 2068} 2069 2070