qtool.pl revision 94334
1#!/usr/bin/env perl 2## 3## Copyright (c) 1998-2002 Sendmail, Inc. and its suppliers. 4## All rights reserved. 5## 6## $Id: qtool.pl,v 8.27 2002/01/29 21:55:49 ca Exp $ 7## 8use strict; 9use File::Basename; 10use File::Copy; 11use File::Spec; 12use Fcntl qw(:flock :DEFAULT); 13use Getopt::Std; 14 15## 16## QTOOL 17## This program is for moving files between sendmail queues. It is 18## pretty similar to just moving the files manually, but it locks the files 19## the same way sendmail does to prevent problems. 20## 21## NOTICE: Do not use this program to move queue files around 22## if you use sendmail 8.12 and multiple queue groups. It may interfere 23## with sendmail's internal queue group selection strategy and can cause 24## mail to be not delivered. 25## 26## The syntax is the reverse of mv (ie. the target argument comes 27## first). This lets you pick the files you want to move using find and 28## xargs. 29## 30## Since you cannot delete queues while sendmail is running, QTOOL 31## assumes that when you specify a directory as a source, you mean that you 32## want all of the queue files within that directory moved, not the 33## directory itself. 34## 35## There is a mechanism for adding conditionals for moving the files. 36## Just create an Object with a check_move(source, dest) method and add it 37## to the $conditions object. See the handling of the '-s' option for an 38## example. 39## 40 41## 42## OPTION NOTES 43## 44## The -e option: 45## The -e option takes any valid perl expression and evaluates it 46## using the eval() function. Inside the expression the variable 47## '$msg' is bound to the ControlFile object for the current source 48## queue message. This lets you check for any value in the message 49## headers or the control file. Here's an example: 50## 51## ./qtool.pl -e '$msg{num_delivery_attempts} >= 2' /q1 /q2 52## 53## This would move any queue files whose number of delivery attempts 54## is greater than or equal to 2 from the queue 'q2' to the queue 'q1'. 55## 56## See the function ControlFile::parse for a list of available 57## variables. 58## 59 60my %opts; 61my %sources; 62my $dst_name; 63my $destination; 64my $source_name; 65my $source; 66my $result; 67my $action; 68my $new_condition; 69my $qprefix; 70my $queuegroups = 0; 71my $conditions = new Compound(); 72 73Getopt::Std::getopts('bC:de:Qs:', \%opts); 74 75sub move_action 76{ 77 my $source = shift; 78 my $destination = shift; 79 80 $result = $destination->add($source); 81 if ($result) 82 { 83 print("$result.\n"); 84 } 85} 86 87sub delete_action 88{ 89 my $source = shift; 90 91 return $source->delete(); 92} 93 94sub bounce_action 95{ 96 my $source = shift; 97 98 return $source->bounce(); 99} 100 101$action = \&move_action; 102if (defined $opts{d}) 103{ 104 $action = \&delete_action; 105} 106elsif (defined $opts{b}) 107{ 108 $action = \&bounce_action; 109} 110 111if (defined $opts{s}) 112{ 113 $new_condition = new OlderThan($opts{s}); 114 $conditions->add($new_condition); 115} 116 117if (defined $opts{e}) 118{ 119 $new_condition = new Eval($opts{e}); 120 $conditions->add($new_condition); 121} 122 123if (defined $opts{Q}) 124{ 125 $qprefix = "hf"; 126} 127else 128{ 129 $qprefix = "qf"; 130} 131 132if ($action == \&move_action) 133{ 134 $dst_name = shift(@ARGV); 135 if (!-d $dst_name) 136 { 137 print("The destination '$dst_name' must be an existing " . 138 "directory.\n"); 139 usage(); 140 exit; 141 } 142 $destination = new Queue($dst_name); 143} 144 145# determine queue_root by reading config file 146my $queue_root; 147{ 148 my $config_file = "/etc/mail/sendmail.cf"; 149 if (defined $opts{C}) 150 { 151 $config_file = $opts{C}; 152 } 153 154 my $line; 155 open(CONFIG_FILE, $config_file) or die "$config_file: $!"; 156 157 ## Notice: we can only break out of this loop (using last) 158 ## when both entries (queue directory and group group) 159 ## have been found. 160 while ($line = <CONFIG_FILE>) 161 { 162 chomp $line; 163 if ($line =~ m/^O QueueDirectory=(.*)/) 164 { 165 $queue_root = $1; 166 if ($queue_root =~ m/(.*)\/[^\/]+\*$/) 167 { 168 $queue_root = $1; 169 } 170 # found also queue groups? 171 if ($queuegroups) 172 { 173 last; 174 } 175 } 176 if ($line =~ m/^Q.*/) 177 { 178 $queuegroups = 1; 179 if ($action == \&move_action) 180 { 181 print("WARNING: moving queue files around " . 182 "when queue groups are used may\n" . 183 "result in undelivered mail!\n"); 184 } 185 # found also queue directory? 186 if (defined $queue_root) 187 { 188 last; 189 } 190 } 191 } 192 close(CONFIG_FILE); 193 if (!defined $queue_root) 194 { 195 die "QueueDirectory option not defined in $config_file"; 196 } 197} 198 199while (@ARGV) 200{ 201 $source_name = shift(@ARGV); 202 $result = add_source(\%sources, $source_name); 203 if ($result) 204 { 205 print("$result.\n"); 206 exit; 207 } 208} 209 210if (keys(%sources) == 0) 211{ 212 exit; 213} 214 215while (($source_name, $source) = each(%sources)) 216{ 217 $result = $conditions->check_move($source, $destination); 218 if ($result) 219 { 220 $result = &{$action}($source, $destination); 221 if ($result) 222 { 223 print("$result\n"); 224 } 225 } 226} 227 228sub usage 229{ 230 print("Usage:\t$0 [options] directory source ...\n"); 231 print("\t$0 [-Q][-d|-b] source ...\n"); 232 print("Options:\n"); 233 print("\t-b\t\tBounce the messages specified by source.\n"); 234 print("\t-C configfile\tSpecify sendmail config file.\n"); 235 print("\t-d\t\tDelete the messages specified by source.\n"); 236 print("\t-e [perl expression]\n"); 237 print("\t\t\tMove only messages for which perl expression\n"); 238 print("\t\t\treturns true.\n"); 239 print("\t-Q\t\tOperate on quarantined files.\n"); 240 print("\t-s [seconds]\tMove only messages whose queue file is older\n"); 241 print("\t\t\tthan seconds.\n"); 242} 243 244## 245## ADD_SOURCE -- Adds a source to the source hash. 246## 247## Determines whether source is a file, directory, or id. Then it 248## creates a QueuedMessage or Queue for that source and adds it to the 249## list. 250## 251## Parameters: 252## sources -- A hash that contains all of the sources. 253## source_name -- The name of the source to add 254## 255## Returns: 256## error_string -- Undef if ok. Error string otherwise. 257## 258## Notes: 259## If a new source comes in with the same ID as a previous 260## source, the previous source gets overwritten in the sources 261## hash. This lets the user specify things like * and it still 262## works nicely. 263## 264 265sub add_source 266{ 267 my $sources = shift; 268 my $source_name = shift; 269 my $source_base_name; 270 my $source_dir_name; 271 my $data_dir_name; 272 my $source_id; 273 my $source_prefix; 274 my $queued_message; 275 my $queue; 276 my $result; 277 278 ($source_base_name, $source_dir_name) = File::Basename::fileparse($source_name); 279 $data_dir_name = $source_dir_name; 280 281 $source_prefix = substr($source_base_name, 0, 2); 282 if (!-d $source_name && $source_prefix ne $qprefix && 283 $source_prefix ne 'df') 284 { 285 $source_base_name = "$qprefix$source_base_name"; 286 $source_name = File::Spec->catfile("$source_dir_name", 287 "$source_base_name"); 288 } 289 $source_id = substr($source_base_name, 2); 290 291 if (!-e $source_name) 292 { 293 $source_name = File::Spec->catfile("$source_dir_name", "qf", 294 "$qprefix$source_id"); 295 if (!-e $source_name) 296 { 297 return "'$source_name' does not exist"; 298 } 299 $data_dir_name = File::Spec->catfile("$source_dir_name", "df"); 300 if (!-d $data_dir_name) 301 { 302 $data_dir_name = $source_dir_name; 303 } 304 $source_dir_name = File::Spec->catfile("$source_dir_name", 305 "qf"); 306 } 307 308 if (-f $source_name) 309 { 310 $queued_message = new QueuedMessage($source_dir_name, 311 $source_id, 312 $data_dir_name); 313 $sources->{$source_id} = $queued_message; 314 return undef; 315 } 316 317 if (!-d $source_name) 318 { 319 return "'$source_name' is not a plain file or a directory"; 320 } 321 322 $queue = new Queue($source_name); 323 $result = $queue->read(); 324 if ($result) 325 { 326 return $result; 327 } 328 329 while (($source_id, $queued_message) = each(%{$queue->{files}})) 330 { 331 $sources->{$source_id} = $queued_message; 332 } 333 334 return undef; 335} 336 337## 338## LOCK_FILE -- Opens and then locks a file. 339## 340## Opens a file for read/write and uses flock to obtain a lock on the 341## file. The flock is Perl's flock which defaults to flock on systems 342## that support it. On systems without flock it falls back to fcntl 343## locking. 344## 345## Parameters: 346## file_name -- The name of the file to open and lock. 347## 348## Returns: 349## (file_handle, error_string) -- If everything works then 350## file_handle is a reference to a file handle and 351## error_string is undef. If there is a problem then 352## file_handle is undef and error_string is a string 353## explaining the problem. 354## 355 356sub lock_file 357{ 358 my $file_name = shift; 359 my $result; 360 361 $result = sysopen(FILE_TO_LOCK, $file_name, Fcntl::O_RDWR); 362 if (!$result) 363 { 364 return (undef, "Unable to open '$file_name': $!"); 365 } 366 367 $result = flock(FILE_TO_LOCK, Fcntl::LOCK_EX | Fcntl::LOCK_NB); 368 if (!$result) 369 { 370 return (undef, "Could not obtain lock on '$file_name': $!"); 371 } 372 373 return (\*FILE_TO_LOCK, undef); 374} 375 376## 377## UNLOCK_FILE -- Unlocks a file. 378## 379## Unlocks a file using Perl's flock. 380## 381## Parameters: 382## file -- A file handle. 383## 384## Returns: 385## error_string -- If undef then no problem. Otherwise it is a 386## string that explains problem. 387## 388 389sub unlock_file 390{ 391 my $file = shift; 392 my $result; 393 394 $result = flock($file, Fcntl::LOCK_UN); 395 if (!$result) 396 { 397 return "Unlock failed on '$result': $!"; 398 } 399 400 return undef; 401} 402 403## 404## MOVE_FILE -- Moves a file. 405## 406## Moves a file. 407## 408## Parameters: 409## src_name -- The name of the file to be move. 410## dst_nome -- The name of the place to move it to. 411## 412## Returns: 413## error_string -- If undef then no problem. Otherwise it is a 414## string that explains problem. 415## 416 417sub move_file 418{ 419 my $src_name = shift; 420 my $dst_name = shift; 421 my $result; 422 423 $result = File::Copy::move($src_name, $dst_name); 424 if (!$result) 425 { 426 return "File move from '$src_name' to '$dst_name' failed: $!"; 427 } 428 429 return undef; 430} 431 432 433## 434## CONTROL_FILE - Represents a sendmail queue control file. 435## 436## This object represents represents a sendmail queue control file. 437## It can parse and lock its file. 438## 439 440 441package ControlFile; 442 443sub new 444{ 445 my $this = shift; 446 my $class = ref($this) || $this; 447 my $self = {}; 448 bless $self, $class; 449 $self->initialize(@_); 450 return $self; 451} 452 453sub initialize 454{ 455 my $self = shift; 456 my $queue_dir = shift; 457 $self->{id} = shift; 458 459 $self->{file_name} = $queue_dir . '/' . $qprefix . $self->{id}; 460 $self->{headers} = {}; 461} 462 463## 464## PARSE - Parses the control file. 465## 466## Parses the control file. It just sticks each entry into a hash. 467## If a key has more than one entry, then it points to a list of 468## entries. 469## 470 471sub parse 472{ 473 my $self = shift; 474 if ($self->{parsed}) 475 { 476 return; 477 } 478 my %parse_table = 479 ( 480 'A' => 'auth', 481 'B' => 'body_type', 482 'C' => 'controlling_user', 483 'D' => 'data_file_name', 484 'd' => 'data_file_directory', 485 'E' => 'error_recipient', 486 'F' => 'flags', 487 'H' => 'parse_header', 488 'G' => 'queue_delay', 489 'I' => 'inode_number', 490 'K' => 'next_delivery_time', 491 'L' => 'content-length', 492 'M' => 'message', 493 'N' => 'num_delivery_attempts', 494 'P' => 'priority', 495 'Q' => 'original_recipient', 496 'R' => 'recipient', 497 'q' => 'quarantine_reason', 498 'r' => 'final_recipient', 499 'S' => 'sender', 500 'T' => 'creation_time', 501 'V' => 'version', 502 'Y' => 'current_delay', 503 'Z' => 'envid', 504 '!' => 'deliver_by', 505 '$' => 'macro' 506 ); 507 my $line; 508 my $line_type; 509 my $line_value; 510 my $member_name; 511 my $member; 512 my $last_type; 513 514 open(CONTROL_FILE, "$self->{file_name}"); 515 while ($line = <CONTROL_FILE>) 516 { 517 $line_type = substr($line, 0, 1); 518 if ($line_type eq "\t" && $last_type eq 'H') 519 { 520 $line_type = 'H'; 521 $line_value = $line; 522 } 523 else 524 { 525 $line_value = substr($line, 1); 526 } 527 $member_name = $parse_table{$line_type}; 528 $last_type = $line_type; 529 if (!$member_name) 530 { 531 $member_name = 'unknown'; 532 } 533 if ($self->can($member_name)) 534 { 535 $self->$member_name($line_value); 536 } 537 $member = $self->{$member_name}; 538 if (!$member) 539 { 540 $self->{$member_name} = $line_value; 541 next; 542 } 543 if (ref($member) eq 'ARRAY') 544 { 545 push(@{$member}, $line_value); 546 next; 547 } 548 $self->{$member_name} = [$member, $line_value]; 549 } 550 close(CONTROL_FILE); 551 552 $self->{parsed} = 1; 553} 554 555sub parse_header 556{ 557 my $self = shift; 558 my $line = shift; 559 my $headers = $self->{headers}; 560 my $last_header = $self->{last_header}; 561 my $header_name; 562 my $header_value; 563 my $first_char; 564 565 $first_char = substr($line, 0, 1); 566 if ($first_char eq "?") 567 { 568 $line = substr($line, 3); 569 } 570 elsif ($first_char eq "\t") 571 { 572 if (ref($headers->{$last_header}) eq 'ARRAY') 573 { 574 $headers->{$last_header}[-1] = 575 $headers->{$last_header}[-1] . $line; 576 } 577 else 578 { 579 $headers->{$last_header} = $headers->{$last_header} . 580 $line; 581 } 582 return; 583 } 584 ($header_name, $header_value) = split(/:/, $line, 2); 585 $self->{last_header} = $header_name; 586 if (exists $headers->{$header_name}) 587 { 588 $headers->{$header_name} = [$headers->{$header_name}, 589 $header_value]; 590 } 591 else 592 { 593 $headers->{$header_name} = $header_value; 594 } 595} 596 597sub is_locked 598{ 599 my $self = shift; 600 601 return (defined $self->{lock_handle}); 602} 603 604sub lock 605{ 606 my $self = shift; 607 my $lock_handle; 608 my $result; 609 610 if ($self->is_locked()) 611 { 612 # Already locked 613 return undef; 614 } 615 616 ($lock_handle, $result) = ::lock_file($self->{file_name}); 617 if (!$lock_handle) 618 { 619 return $result; 620 } 621 622 $self->{lock_handle} = $lock_handle; 623 624 return undef; 625} 626 627sub unlock 628{ 629 my $self = shift; 630 my $result; 631 632 if (!$self->is_locked()) 633 { 634 # Not locked 635 return undef; 636 } 637 638 $result = ::unlock_file($self->{lock_handle}); 639 640 $self->{lock_handle} = undef; 641 642 return $result; 643} 644 645sub do_stat 646{ 647 my $self = shift; 648 my $result; 649 my @result; 650 651 $result = open(QUEUE_FILE, $self->{file_name}); 652 if (!$result) 653 { 654 return "Unable to open '$self->{file_name}': $!"; 655 } 656 @result = stat(QUEUE_FILE); 657 if (!@result) 658 { 659 return "Unable to stat '$self->{file_name}': $!"; 660 } 661 $self->{control_size} = $result[7]; 662 $self->{control_last_mod_time} = $result[9]; 663} 664 665sub DESTROY 666{ 667 my $self = shift; 668 669 $self->unlock(); 670} 671 672sub delete 673{ 674 my $self = shift; 675 my $result; 676 677 $result = unlink($self->{file_name}); 678 if (!$result) 679 { 680 return "Unable to delete $self->{file_name}: $!"; 681 } 682 return undef; 683} 684 685 686## 687## DATA_FILE - Represents a sendmail queue data file. 688## 689## This object represents represents a sendmail queue data file. 690## It is really just a place-holder. 691## 692 693package DataFile; 694 695sub new 696{ 697 my $this = shift; 698 my $class = ref($this) || $this; 699 my $self = {}; 700 bless $self, $class; 701 $self->initialize(@_); 702 return $self; 703} 704 705sub initialize 706{ 707 my $self = shift; 708 my $data_dir = shift; 709 $self->{id} = shift; 710 my $control_file = shift; 711 712 $self->{file_name} = $data_dir . '/df' . $self->{id}; 713 return if -e $self->{file_name}; 714 $control_file->parse(); 715 return if !defined $control_file->{data_file_directory}; 716 $data_dir = $queue_root . '/' . $control_file->{data_file_directory}; 717 chomp $data_dir; 718 if (-d ($data_dir . '/df')) 719 { 720 $data_dir .= '/df'; 721 } 722 $self->{file_name} = $data_dir . '/df' . $self->{id}; 723} 724 725sub do_stat 726{ 727 my $self = shift; 728 my $result; 729 my @result; 730 731 $result = open(QUEUE_FILE, $self->{file_name}); 732 if (!$result) 733 { 734 return "Unable to open '$self->{file_name}': $!"; 735 } 736 @result = stat(QUEUE_FILE); 737 if (!@result) 738 { 739 return "Unable to stat '$self->{file_name}': $!"; 740 } 741 $self->{body_size} = $result[7]; 742 $self->{body_last_mod_time} = $result[9]; 743} 744 745sub delete 746{ 747 my $self = shift; 748 my $result; 749 750 $result = unlink($self->{file_name}); 751 if (!$result) 752 { 753 return "Unable to delete $self->{file_name}: $!"; 754 } 755 return undef; 756} 757 758 759## 760## QUEUED_MESSAGE - Represents a queued sendmail message. 761## 762## This keeps track of the files that make up a queued sendmail 763## message. 764## Currently it has 'control_file' and 'data_file' as members. 765## 766## You can tie it to a fetch only hash using tie. You need to 767## pass a reference to a QueuedMessage as the third argument 768## to tie. 769## 770 771package QueuedMessage; 772 773sub new 774{ 775 my $this = shift; 776 my $class = ref($this) || $this; 777 my $self = {}; 778 bless $self, $class; 779 $self->initialize(@_); 780 return $self; 781} 782 783sub initialize 784{ 785 my $self = shift; 786 my $queue_dir = shift; 787 my $id = shift; 788 my $data_dir = shift; 789 790 $self->{id} = $id; 791 $self->{control_file} = new ControlFile($queue_dir, $id); 792 if (!$data_dir) 793 { 794 $data_dir = $queue_dir; 795 } 796 $self->{data_file} = new DataFile($data_dir, $id, $self->{control_file}); 797} 798 799sub last_modified_time 800{ 801 my $self = shift; 802 my @result; 803 @result = stat($self->{data_file}->{file_name}); 804 return $result[9]; 805} 806 807sub TIEHASH 808{ 809 my $this = shift; 810 my $class = ref($this) || $this; 811 my $self = shift; 812 return $self; 813} 814 815sub FETCH 816{ 817 my $self = shift; 818 my $key = shift; 819 820 if (exists $self->{control_file}->{$key}) 821 { 822 return $self->{control_file}->{$key}; 823 } 824 if (exists $self->{data_file}->{$key}) 825 { 826 return $self->{data_file}->{$key}; 827 } 828 829 return undef; 830} 831 832sub lock 833{ 834 my $self = shift; 835 836 return $self->{control_file}->lock(); 837} 838 839sub unlock 840{ 841 my $self = shift; 842 843 return $self->{control_file}->unlock(); 844} 845 846sub move 847{ 848 my $self = shift; 849 my $destination = shift; 850 my $df_dest; 851 my $qf_dest; 852 my $result; 853 854 $result = $self->lock(); 855 if ($result) 856 { 857 return $result; 858 } 859 860 $qf_dest = File::Spec->catfile($destination, "qf"); 861 if (-d $qf_dest) 862 { 863 $df_dest = File::Spec->catfile($destination, "df"); 864 if (!-d $df_dest) 865 { 866 $df_dest = $destination; 867 } 868 } 869 else 870 { 871 $qf_dest = $destination; 872 $df_dest = $destination; 873 } 874 875 if (-e File::Spec->catfile($qf_dest, "$qprefix$self->{id}")) 876 { 877 $result = "There is already a queued message with id '$self->{id}' in '$destination'"; 878 } 879 880 if (!$result) 881 { 882 $result = ::move_file($self->{data_file}->{file_name}, 883 $df_dest); 884 } 885 886 if (!$result) 887 { 888 $result = ::move_file($self->{control_file}->{file_name}, 889 $qf_dest); 890 } 891 892 $self->unlock(); 893 894 return $result; 895} 896 897sub parse 898{ 899 my $self = shift; 900 901 return $self->{control_file}->parse(); 902} 903 904sub do_stat 905{ 906 my $self = shift; 907 908 $self->{control_file}->do_stat(); 909 $self->{data_file}->do_stat(); 910} 911 912sub setup_vars 913{ 914 my $self = shift; 915 916 $self->parse(); 917 $self->do_stat(); 918} 919 920sub delete 921{ 922 my $self = shift; 923 my $result; 924 925 $result = $self->{control_file}->delete(); 926 if ($result) 927 { 928 return $result; 929 } 930 $result = $self->{data_file}->delete(); 931 if ($result) 932 { 933 return $result; 934 } 935 936 return undef; 937} 938 939sub bounce 940{ 941 my $self = shift; 942 my $command; 943 944 $command = "sendmail -qI$self->{id} -O Timeout.queuereturn=now"; 945# print("$command\n"); 946 system($command); 947} 948 949## 950## QUEUE - Represents a queued sendmail queue. 951## 952## This manages all of the messages in a queue. 953## 954 955package Queue; 956 957sub new 958{ 959 my $this = shift; 960 my $class = ref($this) || $this; 961 my $self = {}; 962 bless $self, $class; 963 $self->initialize(@_); 964 return $self; 965} 966 967sub initialize 968{ 969 my $self = shift; 970 971 $self->{queue_dir} = shift; 972 $self->{files} = {}; 973} 974 975## 976## READ - Loads the queue with all of the objects that reside in it. 977## 978## This reads the queue's directory and creates QueuedMessage objects 979## for every file in the queue that starts with 'qf' or 'hf' 980## (depending on the -Q option). 981## 982 983sub read 984{ 985 my $self = shift; 986 my @control_files; 987 my $queued_message; 988 my $file_name; 989 my $id; 990 my $result; 991 my $control_dir; 992 my $data_dir; 993 994 $control_dir = File::Spec->catfile($self->{queue_dir}, 'qf'); 995 996 if (-e $control_dir) 997 { 998 $data_dir = File::Spec->catfile($self->{queue_dir}, 'df'); 999 if (!-e $data_dir) 1000 { 1001 $data_dir = $self->{queue_dir}; 1002 } 1003 } 1004 else 1005 { 1006 $data_dir = $self->{queue_dir}; 1007 $control_dir = $self->{queue_dir}; 1008 } 1009 1010 $result = opendir(QUEUE_DIR, $control_dir); 1011 if (!$result) 1012 { 1013 return "Unable to open directory '$control_dir'"; 1014 } 1015 1016 @control_files = grep { /^$qprefix.*/ && -f "$control_dir/$_" } readdir(QUEUE_DIR); 1017 closedir(QUEUE_DIR); 1018 foreach $file_name (@control_files) 1019 { 1020 $id = substr($file_name, 2); 1021 $queued_message = new QueuedMessage($control_dir, $id, 1022 $data_dir); 1023 $self->{files}->{$id} = $queued_message; 1024 } 1025 1026 return undef; 1027} 1028 1029 1030## 1031## ADD_QUEUED_MESSAGE - Adds a QueuedMessage to this Queue. 1032## 1033## Adds the QueuedMessage object to the hash and moves the files 1034## associated with the QueuedMessage to this Queue's directory. 1035## 1036 1037sub add_queued_message 1038{ 1039 my $self = shift; 1040 my $queued_message = shift; 1041 my $result; 1042 1043 $result = $queued_message->move($self->{queue_dir}); 1044 if ($result) 1045 { 1046 return $result; 1047 } 1048 1049 $self->{files}->{$queued_message->{id}} = $queued_message; 1050 1051 return $result; 1052} 1053 1054## 1055## ADD_QUEUE - Adds another Queue's QueuedMessages to this Queue. 1056## 1057## Adds all of the QueuedMessage objects in the passed in queue 1058## to this queue. 1059## 1060 1061sub add_queue 1062{ 1063 my $self = shift; 1064 my $queue = shift; 1065 my $id; 1066 my $queued_message; 1067 my $result; 1068 1069 while (($id, $queued_message) = each %{$queue->{files}}) 1070 { 1071 $result = $self->add_queued_message($queued_message); 1072 if ($result) 1073 { 1074 print("$result.\n"); 1075 } 1076 } 1077} 1078 1079## 1080## ADD - Adds an item to this queue. 1081## 1082## Adds either a Queue or a QueuedMessage to this Queue. 1083## 1084 1085sub add 1086{ 1087 my $self = shift; 1088 my $source = shift; 1089 my $type_name; 1090 my $result; 1091 1092 $type_name = ref($source); 1093 1094 if ($type_name eq "QueuedMessage") 1095 { 1096 return $self->add_queued_message($source); 1097 } 1098 1099 if ($type_name eq "Queue") 1100 { 1101 return $self->add_queue($source); 1102 } 1103 1104 return "Queue does not know how to add a '$type_name'" 1105} 1106 1107sub delete 1108{ 1109 my $self = shift; 1110 my $id; 1111 my $queued_message; 1112 1113 while (($id, $queued_message) = each %{$self->{files}}) 1114 { 1115 $result = $queued_message->delete(); 1116 if ($result) 1117 { 1118 print("$result.\n"); 1119 } 1120 } 1121} 1122 1123sub bounce 1124{ 1125 my $self = shift; 1126 my $id; 1127 my $queued_message; 1128 1129 while (($id, $queued_message) = each %{$self->{files}}) 1130 { 1131 $result = $queued_message->bounce(); 1132 if ($result) 1133 { 1134 print("$result.\n"); 1135 } 1136 } 1137} 1138 1139## 1140## Condition Class 1141## 1142## This next section is for any class that has an interface called 1143## check_move(source, dest). Each class represents some condition to 1144## check for to determine whether we should move the file from 1145## source to dest. 1146## 1147 1148 1149## 1150## OlderThan 1151## 1152## This Condition Class checks the modification time of the 1153## source file and returns true if the file's modification time is 1154## older than the number of seconds the class was initialzed with. 1155## 1156 1157package OlderThan; 1158 1159sub new 1160{ 1161 my $this = shift; 1162 my $class = ref($this) || $this; 1163 my $self = {}; 1164 bless $self, $class; 1165 $self->initialize(@_); 1166 return $self; 1167} 1168 1169sub initialize 1170{ 1171 my $self = shift; 1172 1173 $self->{age_in_seconds} = shift; 1174} 1175 1176sub check_move 1177{ 1178 my $self = shift; 1179 my $source = shift; 1180 1181 if ((time() - $source->last_modified_time()) > $self->{age_in_seconds}) 1182 { 1183 return 1; 1184 } 1185 1186 return 0; 1187} 1188 1189## 1190## Compound 1191## 1192## Takes a list of Move Condition Classes. Check_move returns true 1193## if every Condition Class in the list's check_move function returns 1194## true. 1195## 1196 1197package Compound; 1198 1199sub new 1200{ 1201 my $this = shift; 1202 my $class = ref($this) || $this; 1203 my $self = {}; 1204 bless $self, $class; 1205 $self->initialize(@_); 1206 return $self; 1207} 1208 1209sub initialize 1210{ 1211 my $self = shift; 1212 1213 $self->{condition_list} = []; 1214} 1215 1216sub add 1217{ 1218 my $self = shift; 1219 my $new_condition = shift; 1220 1221 push(@{$self->{condition_list}}, $new_condition); 1222} 1223 1224sub check_move 1225{ 1226 my $self = shift; 1227 my $source = shift; 1228 my $dest = shift; 1229 my $condition; 1230 my $result; 1231 1232 foreach $condition (@{$self->{condition_list}}) 1233 { 1234 if (!$condition->check_move($source, $dest)) 1235 { 1236 return 0; 1237 } 1238 } 1239 1240 return 1; 1241} 1242 1243## 1244## Eval 1245## 1246## Takes a perl expression and evaluates it. The ControlFile object 1247## for the source QueuedMessage is avaliable through the name '$msg'. 1248## 1249 1250package Eval; 1251 1252sub new 1253{ 1254 my $this = shift; 1255 my $class = ref($this) || $this; 1256 my $self = {}; 1257 bless $self, $class; 1258 $self->initialize(@_); 1259 return $self; 1260} 1261 1262sub initialize 1263{ 1264 my $self = shift; 1265 1266 $self->{expression} = shift; 1267} 1268 1269sub check_move 1270{ 1271 my $self = shift; 1272 my $source = shift; 1273 my $dest = shift; 1274 my $result; 1275 my %msg; 1276 1277 $source->setup_vars(); 1278 tie(%msg, 'QueuedMessage', $source); 1279 $result = eval($self->{expression}); 1280 1281 return $result; 1282} 1283