qtool.pl revision 168515
161981Sbrian#!/usr/bin/env perl 261981Sbrian## 361981Sbrian## Copyright (c) 1998-2002 Sendmail, Inc. and its suppliers. 461981Sbrian## All rights reserved. 561981Sbrian## 661981Sbrian## $Id: qtool.pl,v 8.29 2007/02/16 01:12:08 ca Exp $ 761981Sbrian## 861981Sbrianuse strict; 961981Sbrianuse File::Basename; 1061981Sbrianuse File::Copy; 1161981Sbrianuse File::Spec; 1261981Sbrianuse Fcntl qw(:flock :DEFAULT); 13140771Skeramidause Getopt::Std; 14140771Skeramida 15140771Skeramida## 1661981Sbrian## QTOOL 1761981Sbrian## This program is for moving files between sendmail queues. It is 1861981Sbrian## pretty similar to just moving the files manually, but it locks the files 1961981Sbrian## the same way sendmail does to prevent problems. 2061981Sbrian## 2161981Sbrian## NOTICE: Do not use this program to move queue files around 2261981Sbrian## if you use sendmail 8.12 and multiple queue groups. It may interfere 23170085Sdougb## with sendmail's internal queue group selection strategy and can cause 2461981Sbrian## mail to be not delivered. 2561981Sbrian## 2661981Sbrian## The syntax is the reverse of mv (ie. the target argument comes 2761981Sbrian## first). This lets you pick the files you want to move using find and 2865843Sbrian## xargs. 2965843Sbrian## 3065843Sbrian## Since you cannot delete queues while sendmail is running, QTOOL 3165843Sbrian## assumes that when you specify a directory as a source, you mean that you 3265843Sbrian## want all of the queue files within that directory moved, not the 3365843Sbrian## directory itself. 3465843Sbrian## 3565843Sbrian## There is a mechanism for adding conditionals for moving the files. 3665843Sbrian## Just create an Object with a check_move(source, dest) method and add it 3765843Sbrian## to the $conditions object. See the handling of the '-s' option for an 3861981Sbrian## example. 3961981Sbrian## 4061981Sbrian 4161981Sbrian## 4261981Sbrian## OPTION NOTES 4361981Sbrian## 4461981Sbrian## The -e option: 4561981Sbrian## The -e option takes any valid perl expression and evaluates it 4661981Sbrian## using the eval() function. Inside the expression the variable 4761981Sbrian## '$msg' is bound to the ControlFile object for the current source 48174028Sjhb## queue message. This lets you check for any value in the message 49174028Sjhb## headers or the control file. Here's an example: 50174028Sjhb## 5161981Sbrian## ./qtool.pl -e '$msg{num_delivery_attempts} >= 2' /q1 /q2 5261981Sbrian## 5361981Sbrian## This would move any queue files whose number of delivery attempts 5461981Sbrian## is greater than or equal to 2 from the queue 'q2' to the queue 'q1'. 5561981Sbrian## 5661981Sbrian## See the function ControlFile::parse for a list of available 5761981Sbrian## variables. 5861981Sbrian## 5961981Sbrian 6061981Sbrianmy %opts; 6161981Sbrianmy %sources; 6261981Sbrianmy $dst_name; 6361981Sbrianmy $destination; 6461981Sbrianmy $source_name; 6561981Sbrianmy $source; 6661981Sbrianmy $result; 6761981Sbrianmy $action; 68108959Swollmanmy $new_condition; 69108959Swollmanmy $qprefix; 7061981Sbrianmy $queuegroups = 0; 7161981Sbrianmy $conditions = new Compound(); 7261981Sbrianmy $fcntl_struct = 's H60'; 7361981Sbrianmy $fcntl_structlockp = pack($fcntl_struct, Fcntl::F_WRLCK, 7461981Sbrian "000000000000000000000000000000000000000000000000000000000000"); 7561981Sbrianmy $fcntl_structunlockp = pack($fcntl_struct, Fcntl::F_UNLCK, 7661981Sbrian "000000000000000000000000000000000000000000000000000000000000"); 7761981Sbrianmy $lock_both = -1; 7861981Sbrian 7961981SbrianGetopt::Std::getopts('bC:de:Qs:', \%opts); 8061981Sbrian 8161981Sbriansub move_action 8262054Sbrian{ 8377496Sbrian my $source = shift; 8477492Sbrian my $destination = shift; 8561981Sbrian 8661981Sbrian $result = $destination->add($source); 8761981Sbrian if ($result) 8861981Sbrian { 8961981Sbrian print("$result.\n"); 9061981Sbrian } 91155060Smatteo} 9261981Sbrian 93168412Spjdsub delete_action 94168412Spjd{ 95168412Spjd my $source = shift; 96121620Sjesper 97123498Sjesper return $source->delete(); 98121620Sjesper} 99154304Swollman 100154304Swollmansub bounce_action 101154304Swollman{ 102156216Sbrueffer my $source = shift; 103156216Sbrueffer 104156216Sbrueffer return $source->bounce(); 105156216Sbrueffer} 106156216Sbrueffer 107156216Sbrueffer$action = \&move_action; 108156216Sbruefferif (defined $opts{d}) 109156216Sbrueffer{ 110156216Sbrueffer $action = \&delete_action; 11161981Sbrian} 11261981Sbrianelsif (defined $opts{b}) 11361981Sbrian{ 11461981Sbrian $action = \&bounce_action; 11561981Sbrian} 11661981Sbrian 11761981Sbrianif (defined $opts{s}) 11861981Sbrian{ 11961981Sbrian $new_condition = new OlderThan($opts{s}); 12061981Sbrian $conditions->add($new_condition); 12194342Sgshapiro} 12261981Sbrian 12361981Sbrianif (defined $opts{e}) 12461981Sbrian{ 12587514Scjc $new_condition = new Eval($opts{e}); 12661981Sbrian $conditions->add($new_condition); 12761981Sbrian} 12861981Sbrian 12962274Sbrianif (defined $opts{Q}) 13061981Sbrian{ 13175809Sdirk $qprefix = "hf"; 13275809Sdirk} 13375809Sdirkelse 13475809Sdirk{ 135169517Smaxim $qprefix = "qf"; 136169517Smaxim} 137169517Smaxim 13872677Speterif ($action == \&move_action) 13972677Speter{ 14094342Sgshapiro $dst_name = shift(@ARGV); 14172677Speter if (!-d $dst_name) 14261981Sbrian { 14361981Sbrian print("The destination '$dst_name' must be an existing " . 14461981Sbrian "directory.\n"); 14561981Sbrian usage(); 14687514Scjc exit; 14787514Scjc } 148101607Sfanf $destination = new Queue($dst_name); 14987514Scjc} 15087514Scjc 15187514Scjc# determine queue_root by reading config file 15287514Scjcmy $queue_root; 15387514Scjc{ 154135591Sjkoshy my $config_file = "/etc/mail/sendmail.cf"; 15587514Scjc if (defined $opts{C}) 15687514Scjc { 15787514Scjc $config_file = $opts{C}; 15887514Scjc } 15987514Scjc 16087514Scjc my $line; 16187514Scjc open(CONFIG_FILE, $config_file) or die "$config_file: $!"; 16287514Scjc 16387514Scjc ## Notice: we can only break out of this loop (using last) 16487514Scjc ## when both entries (queue directory and group group) 16587514Scjc ## have been found. 16687514Scjc while ($line = <CONFIG_FILE>) 16787514Scjc { 16887514Scjc chomp $line; 16987514Scjc if ($line =~ m/^O QueueDirectory=(.*)/) 170161602Strhodes { 171161602Strhodes $queue_root = $1; 172161602Strhodes if ($queue_root =~ m/(.*)\/[^\/]+\*$/) 17387514Scjc { 17487514Scjc $queue_root = $1; 17587514Scjc } 176105937Sthomas # found also queue groups? 177105937Sthomas if ($queuegroups) 178105937Sthomas { 179138061Smlaier last; 180138061Smlaier } 181138061Smlaier } 18287514Scjc if ($line =~ m/^Q.*/) 18387514Scjc { 18487514Scjc $queuegroups = 1; 185128473Sdarrenr if ($action == \&move_action) 186128473Sdarrenr { 187128473Sdarrenr print("WARNING: moving queue files around " . 18887514Scjc "when queue groups are used may\n" . 18987514Scjc "result in undelivered mail!\n"); 19087514Scjc } 19187514Scjc # found also queue directory? 19287514Scjc if (defined $queue_root) 19387514Scjc { 19487514Scjc last; 19587514Scjc } 19687514Scjc } 19787514Scjc } 19861981Sbrian close(CONFIG_FILE); 19961981Sbrian if (!defined $queue_root) 20065843Sbrian { 20165843Sbrian die "QueueDirectory option not defined in $config_file"; 20265843Sbrian } 20365843Sbrian} 20465843Sbrian 20565843Sbrianwhile (@ARGV) 20665843Sbrian{ 20765843Sbrian $source_name = shift(@ARGV); 20865843Sbrian $result = add_source(\%sources, $source_name); 20965843Sbrian if ($result) 21061981Sbrian { 21161981Sbrian print("$result.\n"); 21261981Sbrian exit; 21361981Sbrian } 21461981Sbrian} 21561981Sbrian 21661981Sbrianif (keys(%sources) == 0) 21761981Sbrian{ 21861981Sbrian exit; 21961981Sbrian} 22061981Sbrian 22161981Sbrianwhile (($source_name, $source) = each(%sources)) 22261981Sbrian{ 22362206Sbrian $result = $conditions->check_move($source, $destination); 22462155Sbrian if ($result) 225103948Sbrian { 226161664Sdougb $result = &{$action}($source, $destination); 22762155Sbrian if ($result) 22861981Sbrian { 22961981Sbrian print("$result\n"); 23061981Sbrian } 23161981Sbrian } 23261981Sbrian} 23361981Sbrian 23465843Sbriansub usage 23565843Sbrian{ 23665843Sbrian print("Usage:\t$0 [options] directory source ...\n"); 23765843Sbrian print("\t$0 [-Q][-d|-b] source ...\n"); 23865843Sbrian print("Options:\n"); 23965843Sbrian print("\t-b\t\tBounce the messages specified by source.\n"); 24065843Sbrian print("\t-C configfile\tSpecify sendmail config file.\n"); 24165843Sbrian print("\t-d\t\tDelete the messages specified by source.\n"); 24265843Sbrian print("\t-e [perl expression]\n"); 24365843Sbrian print("\t\t\tMove only messages for which perl expression\n"); 24461981Sbrian print("\t\t\treturns true.\n"); 24561981Sbrian print("\t-Q\t\tOperate on quarantined files.\n"); 24661981Sbrian print("\t-s [seconds]\tMove only messages whose queue file is older\n"); 24761981Sbrian print("\t\t\tthan seconds.\n"); 24861981Sbrian} 24961981Sbrian 25061981Sbrian## 25161981Sbrian## ADD_SOURCE -- Adds a source to the source hash. 25261981Sbrian## 25361981Sbrian## Determines whether source is a file, directory, or id. Then it 25461981Sbrian## creates a QueuedMessage or Queue for that source and adds it to the 25561981Sbrian## list. 25661981Sbrian## 25761981Sbrian## Parameters: 25861981Sbrian## sources -- A hash that contains all of the sources. 25961981Sbrian## source_name -- The name of the source to add 26061981Sbrian## 26161981Sbrian## Returns: 26261981Sbrian## error_string -- Undef if ok. Error string otherwise. 26361981Sbrian## 26461981Sbrian## Notes: 26561981Sbrian## If a new source comes in with the same ID as a previous 26661981Sbrian## source, the previous source gets overwritten in the sources 26761981Sbrian## hash. This lets the user specify things like * and it still 26861981Sbrian## works nicely. 26961981Sbrian## 27061981Sbrian 271sub add_source 272{ 273 my $sources = shift; 274 my $source_name = shift; 275 my $source_base_name; 276 my $source_dir_name; 277 my $data_dir_name; 278 my $source_id; 279 my $source_prefix; 280 my $queued_message; 281 my $queue; 282 my $result; 283 284 ($source_base_name, $source_dir_name) = File::Basename::fileparse($source_name); 285 $data_dir_name = $source_dir_name; 286 287 $source_prefix = substr($source_base_name, 0, 2); 288 if (!-d $source_name && $source_prefix ne $qprefix && 289 $source_prefix ne 'df') 290 { 291 $source_base_name = "$qprefix$source_base_name"; 292 $source_name = File::Spec->catfile("$source_dir_name", 293 "$source_base_name"); 294 } 295 $source_id = substr($source_base_name, 2); 296 297 if (!-e $source_name) 298 { 299 $source_name = File::Spec->catfile("$source_dir_name", "qf", 300 "$qprefix$source_id"); 301 if (!-e $source_name) 302 { 303 return "'$source_name' does not exist"; 304 } 305 $data_dir_name = File::Spec->catfile("$source_dir_name", "df"); 306 if (!-d $data_dir_name) 307 { 308 $data_dir_name = $source_dir_name; 309 } 310 $source_dir_name = File::Spec->catfile("$source_dir_name", 311 "qf"); 312 } 313 314 if (-f $source_name) 315 { 316 $queued_message = new QueuedMessage($source_dir_name, 317 $source_id, 318 $data_dir_name); 319 $sources->{$source_id} = $queued_message; 320 return undef; 321 } 322 323 if (!-d $source_name) 324 { 325 return "'$source_name' is not a plain file or a directory"; 326 } 327 328 $queue = new Queue($source_name); 329 $result = $queue->read(); 330 if ($result) 331 { 332 return $result; 333 } 334 335 while (($source_id, $queued_message) = each(%{$queue->{files}})) 336 { 337 $sources->{$source_id} = $queued_message; 338 } 339 340 return undef; 341} 342 343## 344## LOCK_FILE -- Opens and then locks a file. 345## 346## Opens a file for read/write and uses flock to obtain a lock on the 347## file. The flock is Perl's flock which defaults to flock on systems 348## that support it. On systems without flock it falls back to fcntl 349## locking. This script will also call fcntl explicitly if flock 350## uses BSD semantics (i.e. if both flock() and fcntl() can successfully 351## lock the file at the same time) 352## 353## Parameters: 354## file_name -- The name of the file to open and lock. 355## 356## Returns: 357## (file_handle, error_string) -- If everything works then 358## file_handle is a reference to a file handle and 359## error_string is undef. If there is a problem then 360## file_handle is undef and error_string is a string 361## explaining the problem. 362## 363 364sub lock_file 365{ 366 my $file_name = shift; 367 my $result; 368 369 if ($lock_both == -1) 370 { 371 if (open(DEVNULL, '>/dev/null')) 372 { 373 my $flock_status = flock(DEVNULL, Fcntl::LOCK_EX | Fcntl::LOCK_NB); 374 my $fcntl_status = fcntl (DEVNULL, Fcntl::F_SETLK, $fcntl_structlockp); 375 close(DEVNULL); 376 377 $lock_both = ($flock_status && $fcntl_status); 378 } 379 else 380 { 381 # Couldn't open /dev/null. Windows system? 382 $lock_both = 0; 383 } 384 } 385 386 387 $result = sysopen(FILE_TO_LOCK, $file_name, Fcntl::O_RDWR); 388 if (!$result) 389 { 390 return (undef, "Unable to open '$file_name': $!"); 391 } 392 393 $result = flock(FILE_TO_LOCK, Fcntl::LOCK_EX | Fcntl::LOCK_NB); 394 if (!$result) 395 { 396 return (undef, "Could not obtain lock on '$file_name': $!"); 397 } 398 399 if ($lock_both) 400 { 401 my $result2 = fcntl (FILE_TO_LOCK, Fcntl::F_SETLK, $fcntl_structlockp); 402 if (!$result2) 403 { 404 return (undef, "Could not obtain fcntl lock on '$file_name': $!"); 405 } 406 } 407 408 return (\*FILE_TO_LOCK, undef); 409} 410 411## 412## UNLOCK_FILE -- Unlocks a file. 413## 414## Unlocks a file using Perl's flock. 415## 416## Parameters: 417## file -- A file handle. 418## 419## Returns: 420## error_string -- If undef then no problem. Otherwise it is a 421## string that explains problem. 422## 423 424sub unlock_file 425{ 426 my $file = shift; 427 my $result; 428 429 $result = flock($file, Fcntl::LOCK_UN); 430 if (!$result) 431 { 432 return "Unlock failed on '$result': $!"; 433 } 434 if ($lock_both) 435 { 436 my $result2 = fcntl ($file, Fcntl::F_SETLK, $fcntl_structunlockp); 437 if (!$result2) 438 { 439 return (undef, "Fcntl unlock failed on '$result': $!"); 440 } 441 } 442 443 return undef; 444} 445 446## 447## MOVE_FILE -- Moves a file. 448## 449## Moves a file. 450## 451## Parameters: 452## src_name -- The name of the file to be move. 453## dst_nome -- The name of the place to move it to. 454## 455## Returns: 456## error_string -- If undef then no problem. Otherwise it is a 457## string that explains problem. 458## 459 460sub move_file 461{ 462 my $src_name = shift; 463 my $dst_name = shift; 464 my $result; 465 466 $result = File::Copy::move($src_name, $dst_name); 467 if (!$result) 468 { 469 return "File move from '$src_name' to '$dst_name' failed: $!"; 470 } 471 472 return undef; 473} 474 475 476## 477## CONTROL_FILE - Represents a sendmail queue control file. 478## 479## This object represents represents a sendmail queue control file. 480## It can parse and lock its file. 481## 482 483 484package ControlFile; 485 486sub new 487{ 488 my $this = shift; 489 my $class = ref($this) || $this; 490 my $self = {}; 491 bless $self, $class; 492 $self->initialize(@_); 493 return $self; 494} 495 496sub initialize 497{ 498 my $self = shift; 499 my $queue_dir = shift; 500 $self->{id} = shift; 501 502 $self->{file_name} = $queue_dir . '/' . $qprefix . $self->{id}; 503 $self->{headers} = {}; 504} 505 506## 507## PARSE - Parses the control file. 508## 509## Parses the control file. It just sticks each entry into a hash. 510## If a key has more than one entry, then it points to a list of 511## entries. 512## 513 514sub parse 515{ 516 my $self = shift; 517 if ($self->{parsed}) 518 { 519 return; 520 } 521 my %parse_table = 522 ( 523 'A' => 'auth', 524 'B' => 'body_type', 525 'C' => 'controlling_user', 526 'D' => 'data_file_name', 527 'd' => 'data_file_directory', 528 'E' => 'error_recipient', 529 'F' => 'flags', 530 'H' => 'parse_header', 531 'I' => 'inode_number', 532 'K' => 'next_delivery_time', 533 'L' => 'content-length', 534 'M' => 'message', 535 'N' => 'num_delivery_attempts', 536 'P' => 'priority', 537 'Q' => 'original_recipient', 538 'R' => 'recipient', 539 'q' => 'quarantine_reason', 540 'r' => 'final_recipient', 541 'S' => 'sender', 542 'T' => 'creation_time', 543 'V' => 'version', 544 'Y' => 'current_delay', 545 'Z' => 'envid', 546 '!' => 'deliver_by', 547 '$' => 'macro' 548 ); 549 my $line; 550 my $line_type; 551 my $line_value; 552 my $member_name; 553 my $member; 554 my $last_type; 555 556 open(CONTROL_FILE, "$self->{file_name}"); 557 while ($line = <CONTROL_FILE>) 558 { 559 $line_type = substr($line, 0, 1); 560 if ($line_type eq "\t" && $last_type eq 'H') 561 { 562 $line_type = 'H'; 563 $line_value = $line; 564 } 565 else 566 { 567 $line_value = substr($line, 1); 568 } 569 $member_name = $parse_table{$line_type}; 570 $last_type = $line_type; 571 if (!$member_name) 572 { 573 $member_name = 'unknown'; 574 } 575 if ($self->can($member_name)) 576 { 577 $self->$member_name($line_value); 578 } 579 $member = $self->{$member_name}; 580 if (!$member) 581 { 582 $self->{$member_name} = $line_value; 583 next; 584 } 585 if (ref($member) eq 'ARRAY') 586 { 587 push(@{$member}, $line_value); 588 next; 589 } 590 $self->{$member_name} = [$member, $line_value]; 591 } 592 close(CONTROL_FILE); 593 594 $self->{parsed} = 1; 595} 596 597sub parse_header 598{ 599 my $self = shift; 600 my $line = shift; 601 my $headers = $self->{headers}; 602 my $last_header = $self->{last_header}; 603 my $header_name; 604 my $header_value; 605 my $first_char; 606 607 $first_char = substr($line, 0, 1); 608 if ($first_char eq "?") 609 { 610 $line = substr($line, 3); 611 } 612 elsif ($first_char eq "\t") 613 { 614 if (ref($headers->{$last_header}) eq 'ARRAY') 615 { 616 $headers->{$last_header}[-1] = 617 $headers->{$last_header}[-1] . $line; 618 } 619 else 620 { 621 $headers->{$last_header} = $headers->{$last_header} . 622 $line; 623 } 624 return; 625 } 626 ($header_name, $header_value) = split(/:/, $line, 2); 627 $self->{last_header} = $header_name; 628 if (exists $headers->{$header_name}) 629 { 630 $headers->{$header_name} = [$headers->{$header_name}, 631 $header_value]; 632 } 633 else 634 { 635 $headers->{$header_name} = $header_value; 636 } 637} 638 639sub is_locked 640{ 641 my $self = shift; 642 643 return (defined $self->{lock_handle}); 644} 645 646sub lock 647{ 648 my $self = shift; 649 my $lock_handle; 650 my $result; 651 652 if ($self->is_locked()) 653 { 654 # Already locked 655 return undef; 656 } 657 658 ($lock_handle, $result) = ::lock_file($self->{file_name}); 659 if (!$lock_handle) 660 { 661 return $result; 662 } 663 664 $self->{lock_handle} = $lock_handle; 665 666 return undef; 667} 668 669sub unlock 670{ 671 my $self = shift; 672 my $result; 673 674 if (!$self->is_locked()) 675 { 676 # Not locked 677 return undef; 678 } 679 680 $result = ::unlock_file($self->{lock_handle}); 681 682 $self->{lock_handle} = undef; 683 684 return $result; 685} 686 687sub do_stat 688{ 689 my $self = shift; 690 my $result; 691 my @result; 692 693 $result = open(QUEUE_FILE, $self->{file_name}); 694 if (!$result) 695 { 696 return "Unable to open '$self->{file_name}': $!"; 697 } 698 @result = stat(QUEUE_FILE); 699 if (!@result) 700 { 701 return "Unable to stat '$self->{file_name}': $!"; 702 } 703 $self->{control_size} = $result[7]; 704 $self->{control_last_mod_time} = $result[9]; 705} 706 707sub DESTROY 708{ 709 my $self = shift; 710 711 $self->unlock(); 712} 713 714sub delete 715{ 716 my $self = shift; 717 my $result; 718 719 $result = unlink($self->{file_name}); 720 if (!$result) 721 { 722 return "Unable to delete $self->{file_name}: $!"; 723 } 724 return undef; 725} 726 727 728## 729## DATA_FILE - Represents a sendmail queue data file. 730## 731## This object represents represents a sendmail queue data file. 732## It is really just a place-holder. 733## 734 735package DataFile; 736 737sub new 738{ 739 my $this = shift; 740 my $class = ref($this) || $this; 741 my $self = {}; 742 bless $self, $class; 743 $self->initialize(@_); 744 return $self; 745} 746 747sub initialize 748{ 749 my $self = shift; 750 my $data_dir = shift; 751 $self->{id} = shift; 752 my $control_file = shift; 753 754 $self->{file_name} = $data_dir . '/df' . $self->{id}; 755 return if -e $self->{file_name}; 756 $control_file->parse(); 757 return if !defined $control_file->{data_file_directory}; 758 $data_dir = $queue_root . '/' . $control_file->{data_file_directory}; 759 chomp $data_dir; 760 if (-d ($data_dir . '/df')) 761 { 762 $data_dir .= '/df'; 763 } 764 $self->{file_name} = $data_dir . '/df' . $self->{id}; 765} 766 767sub do_stat 768{ 769 my $self = shift; 770 my $result; 771 my @result; 772 773 $result = open(QUEUE_FILE, $self->{file_name}); 774 if (!$result) 775 { 776 return "Unable to open '$self->{file_name}': $!"; 777 } 778 @result = stat(QUEUE_FILE); 779 if (!@result) 780 { 781 return "Unable to stat '$self->{file_name}': $!"; 782 } 783 $self->{body_size} = $result[7]; 784 $self->{body_last_mod_time} = $result[9]; 785} 786 787sub delete 788{ 789 my $self = shift; 790 my $result; 791 792 $result = unlink($self->{file_name}); 793 if (!$result) 794 { 795 return "Unable to delete $self->{file_name}: $!"; 796 } 797 return undef; 798} 799 800 801## 802## QUEUED_MESSAGE - Represents a queued sendmail message. 803## 804## This keeps track of the files that make up a queued sendmail 805## message. 806## Currently it has 'control_file' and 'data_file' as members. 807## 808## You can tie it to a fetch only hash using tie. You need to 809## pass a reference to a QueuedMessage as the third argument 810## to tie. 811## 812 813package QueuedMessage; 814 815sub new 816{ 817 my $this = shift; 818 my $class = ref($this) || $this; 819 my $self = {}; 820 bless $self, $class; 821 $self->initialize(@_); 822 return $self; 823} 824 825sub initialize 826{ 827 my $self = shift; 828 my $queue_dir = shift; 829 my $id = shift; 830 my $data_dir = shift; 831 832 $self->{id} = $id; 833 $self->{control_file} = new ControlFile($queue_dir, $id); 834 if (!$data_dir) 835 { 836 $data_dir = $queue_dir; 837 } 838 $self->{data_file} = new DataFile($data_dir, $id, $self->{control_file}); 839} 840 841sub last_modified_time 842{ 843 my $self = shift; 844 my @result; 845 @result = stat($self->{data_file}->{file_name}); 846 return $result[9]; 847} 848 849sub TIEHASH 850{ 851 my $this = shift; 852 my $class = ref($this) || $this; 853 my $self = shift; 854 return $self; 855} 856 857sub FETCH 858{ 859 my $self = shift; 860 my $key = shift; 861 862 if (exists $self->{control_file}->{$key}) 863 { 864 return $self->{control_file}->{$key}; 865 } 866 if (exists $self->{data_file}->{$key}) 867 { 868 return $self->{data_file}->{$key}; 869 } 870 871 return undef; 872} 873 874sub lock 875{ 876 my $self = shift; 877 878 return $self->{control_file}->lock(); 879} 880 881sub unlock 882{ 883 my $self = shift; 884 885 return $self->{control_file}->unlock(); 886} 887 888sub move 889{ 890 my $self = shift; 891 my $destination = shift; 892 my $df_dest; 893 my $qf_dest; 894 my $result; 895 896 $result = $self->lock(); 897 if ($result) 898 { 899 return $result; 900 } 901 902 $qf_dest = File::Spec->catfile($destination, "qf"); 903 if (-d $qf_dest) 904 { 905 $df_dest = File::Spec->catfile($destination, "df"); 906 if (!-d $df_dest) 907 { 908 $df_dest = $destination; 909 } 910 } 911 else 912 { 913 $qf_dest = $destination; 914 $df_dest = $destination; 915 } 916 917 if (-e File::Spec->catfile($qf_dest, "$qprefix$self->{id}")) 918 { 919 $result = "There is already a queued message with id '$self->{id}' in '$destination'"; 920 } 921 922 if (!$result) 923 { 924 $result = ::move_file($self->{data_file}->{file_name}, 925 $df_dest); 926 } 927 928 if (!$result) 929 { 930 $result = ::move_file($self->{control_file}->{file_name}, 931 $qf_dest); 932 } 933 934 $self->unlock(); 935 936 return $result; 937} 938 939sub parse 940{ 941 my $self = shift; 942 943 return $self->{control_file}->parse(); 944} 945 946sub do_stat 947{ 948 my $self = shift; 949 950 $self->{control_file}->do_stat(); 951 $self->{data_file}->do_stat(); 952} 953 954sub setup_vars 955{ 956 my $self = shift; 957 958 $self->parse(); 959 $self->do_stat(); 960} 961 962sub delete 963{ 964 my $self = shift; 965 my $result; 966 967 $result = $self->{control_file}->delete(); 968 if ($result) 969 { 970 return $result; 971 } 972 $result = $self->{data_file}->delete(); 973 if ($result) 974 { 975 return $result; 976 } 977 978 return undef; 979} 980 981sub bounce 982{ 983 my $self = shift; 984 my $command; 985 986 $command = "sendmail -qI$self->{id} -O Timeout.queuereturn=now"; 987# print("$command\n"); 988 system($command); 989} 990 991## 992## QUEUE - Represents a queued sendmail queue. 993## 994## This manages all of the messages in a queue. 995## 996 997package Queue; 998 999sub new 1000{ 1001 my $this = shift; 1002 my $class = ref($this) || $this; 1003 my $self = {}; 1004 bless $self, $class; 1005 $self->initialize(@_); 1006 return $self; 1007} 1008 1009sub initialize 1010{ 1011 my $self = shift; 1012 1013 $self->{queue_dir} = shift; 1014 $self->{files} = {}; 1015} 1016 1017## 1018## READ - Loads the queue with all of the objects that reside in it. 1019## 1020## This reads the queue's directory and creates QueuedMessage objects 1021## for every file in the queue that starts with 'qf' or 'hf' 1022## (depending on the -Q option). 1023## 1024 1025sub read 1026{ 1027 my $self = shift; 1028 my @control_files; 1029 my $queued_message; 1030 my $file_name; 1031 my $id; 1032 my $result; 1033 my $control_dir; 1034 my $data_dir; 1035 1036 $control_dir = File::Spec->catfile($self->{queue_dir}, 'qf'); 1037 1038 if (-e $control_dir) 1039 { 1040 $data_dir = File::Spec->catfile($self->{queue_dir}, 'df'); 1041 if (!-e $data_dir) 1042 { 1043 $data_dir = $self->{queue_dir}; 1044 } 1045 } 1046 else 1047 { 1048 $data_dir = $self->{queue_dir}; 1049 $control_dir = $self->{queue_dir}; 1050 } 1051 1052 $result = opendir(QUEUE_DIR, $control_dir); 1053 if (!$result) 1054 { 1055 return "Unable to open directory '$control_dir'"; 1056 } 1057 1058 @control_files = grep { /^$qprefix.*/ && -f "$control_dir/$_" } readdir(QUEUE_DIR); 1059 closedir(QUEUE_DIR); 1060 foreach $file_name (@control_files) 1061 { 1062 $id = substr($file_name, 2); 1063 $queued_message = new QueuedMessage($control_dir, $id, 1064 $data_dir); 1065 $self->{files}->{$id} = $queued_message; 1066 } 1067 1068 return undef; 1069} 1070 1071 1072## 1073## ADD_QUEUED_MESSAGE - Adds a QueuedMessage to this Queue. 1074## 1075## Adds the QueuedMessage object to the hash and moves the files 1076## associated with the QueuedMessage to this Queue's directory. 1077## 1078 1079sub add_queued_message 1080{ 1081 my $self = shift; 1082 my $queued_message = shift; 1083 my $result; 1084 1085 $result = $queued_message->move($self->{queue_dir}); 1086 if ($result) 1087 { 1088 return $result; 1089 } 1090 1091 $self->{files}->{$queued_message->{id}} = $queued_message; 1092 1093 return $result; 1094} 1095 1096## 1097## ADD_QUEUE - Adds another Queue's QueuedMessages to this Queue. 1098## 1099## Adds all of the QueuedMessage objects in the passed in queue 1100## to this queue. 1101## 1102 1103sub add_queue 1104{ 1105 my $self = shift; 1106 my $queue = shift; 1107 my $id; 1108 my $queued_message; 1109 my $result; 1110 1111 while (($id, $queued_message) = each %{$queue->{files}}) 1112 { 1113 $result = $self->add_queued_message($queued_message); 1114 if ($result) 1115 { 1116 print("$result.\n"); 1117 } 1118 } 1119} 1120 1121## 1122## ADD - Adds an item to this queue. 1123## 1124## Adds either a Queue or a QueuedMessage to this Queue. 1125## 1126 1127sub add 1128{ 1129 my $self = shift; 1130 my $source = shift; 1131 my $type_name; 1132 my $result; 1133 1134 $type_name = ref($source); 1135 1136 if ($type_name eq "QueuedMessage") 1137 { 1138 return $self->add_queued_message($source); 1139 } 1140 1141 if ($type_name eq "Queue") 1142 { 1143 return $self->add_queue($source); 1144 } 1145 1146 return "Queue does not know how to add a '$type_name'" 1147} 1148 1149sub delete 1150{ 1151 my $self = shift; 1152 my $id; 1153 my $queued_message; 1154 1155 while (($id, $queued_message) = each %{$self->{files}}) 1156 { 1157 $result = $queued_message->delete(); 1158 if ($result) 1159 { 1160 print("$result.\n"); 1161 } 1162 } 1163} 1164 1165sub bounce 1166{ 1167 my $self = shift; 1168 my $id; 1169 my $queued_message; 1170 1171 while (($id, $queued_message) = each %{$self->{files}}) 1172 { 1173 $result = $queued_message->bounce(); 1174 if ($result) 1175 { 1176 print("$result.\n"); 1177 } 1178 } 1179} 1180 1181## 1182## Condition Class 1183## 1184## This next section is for any class that has an interface called 1185## check_move(source, dest). Each class represents some condition to 1186## check for to determine whether we should move the file from 1187## source to dest. 1188## 1189 1190 1191## 1192## OlderThan 1193## 1194## This Condition Class checks the modification time of the 1195## source file and returns true if the file's modification time is 1196## older than the number of seconds the class was initialzed with. 1197## 1198 1199package OlderThan; 1200 1201sub new 1202{ 1203 my $this = shift; 1204 my $class = ref($this) || $this; 1205 my $self = {}; 1206 bless $self, $class; 1207 $self->initialize(@_); 1208 return $self; 1209} 1210 1211sub initialize 1212{ 1213 my $self = shift; 1214 1215 $self->{age_in_seconds} = shift; 1216} 1217 1218sub check_move 1219{ 1220 my $self = shift; 1221 my $source = shift; 1222 1223 if ((time() - $source->last_modified_time()) > $self->{age_in_seconds}) 1224 { 1225 return 1; 1226 } 1227 1228 return 0; 1229} 1230 1231## 1232## Compound 1233## 1234## Takes a list of Move Condition Classes. Check_move returns true 1235## if every Condition Class in the list's check_move function returns 1236## true. 1237## 1238 1239package Compound; 1240 1241sub new 1242{ 1243 my $this = shift; 1244 my $class = ref($this) || $this; 1245 my $self = {}; 1246 bless $self, $class; 1247 $self->initialize(@_); 1248 return $self; 1249} 1250 1251sub initialize 1252{ 1253 my $self = shift; 1254 1255 $self->{condition_list} = []; 1256} 1257 1258sub add 1259{ 1260 my $self = shift; 1261 my $new_condition = shift; 1262 1263 push(@{$self->{condition_list}}, $new_condition); 1264} 1265 1266sub check_move 1267{ 1268 my $self = shift; 1269 my $source = shift; 1270 my $dest = shift; 1271 my $condition; 1272 my $result; 1273 1274 foreach $condition (@{$self->{condition_list}}) 1275 { 1276 if (!$condition->check_move($source, $dest)) 1277 { 1278 return 0; 1279 } 1280 } 1281 1282 return 1; 1283} 1284 1285## 1286## Eval 1287## 1288## Takes a perl expression and evaluates it. The ControlFile object 1289## for the source QueuedMessage is avaliable through the name '$msg'. 1290## 1291 1292package Eval; 1293 1294sub new 1295{ 1296 my $this = shift; 1297 my $class = ref($this) || $this; 1298 my $self = {}; 1299 bless $self, $class; 1300 $self->initialize(@_); 1301 return $self; 1302} 1303 1304sub initialize 1305{ 1306 my $self = shift; 1307 1308 $self->{expression} = shift; 1309} 1310 1311sub check_move 1312{ 1313 my $self = shift; 1314 my $source = shift; 1315 my $dest = shift; 1316 my $result; 1317 my %msg; 1318 1319 $source->setup_vars(); 1320 tie(%msg, 'QueuedMessage', $source); 1321 $result = eval($self->{expression}); 1322 1323 return $result; 1324} 1325