1#!/usr/bin/env perl 2## 3## Copyright (c) 1998-2002 Proofpoint, Inc. and its suppliers. 4## All rights reserved. 5## 6## $Id: qtool.pl,v 8.32 2013-11-22 20:51:18 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(); 72my $fcntl_struct = 's H60'; 73my $fcntl_structlockp = pack($fcntl_struct, Fcntl::F_WRLCK, 74 "000000000000000000000000000000000000000000000000000000000000"); 75my $fcntl_structunlockp = pack($fcntl_struct, Fcntl::F_UNLCK, 76 "000000000000000000000000000000000000000000000000000000000000"); 77my $lock_both = -1; 78 79Getopt::Std::getopts('bC:de:Qs:', \%opts); 80 81sub move_action 82{ 83 my $source = shift; 84 my $destination = shift; 85 86 $result = $destination->add($source); 87 if ($result) 88 { 89 print("$result.\n"); 90 } 91} 92 93sub delete_action 94{ 95 my $source = shift; 96 97 return $source->delete(); 98} 99 100sub bounce_action 101{ 102 my $source = shift; 103 104 return $source->bounce(); 105} 106 107$action = \&move_action; 108if (defined $opts{d}) 109{ 110 $action = \&delete_action; 111} 112elsif (defined $opts{b}) 113{ 114 $action = \&bounce_action; 115} 116 117if (defined $opts{s}) 118{ 119 $new_condition = new OlderThan($opts{s}); 120 $conditions->add($new_condition); 121} 122 123if (defined $opts{e}) 124{ 125 $new_condition = new Eval($opts{e}); 126 $conditions->add($new_condition); 127} 128 129if (defined $opts{Q}) 130{ 131 $qprefix = "hf"; 132} 133else 134{ 135 $qprefix = "qf"; 136} 137 138if ($action == \&move_action) 139{ 140 $dst_name = shift(@ARGV); 141 if (!-d $dst_name) 142 { 143 print("The destination '$dst_name' must be an existing " . 144 "directory.\n"); 145 usage(); 146 exit; 147 } 148 $destination = new Queue($dst_name); 149} 150 151# determine queue_root by reading config file 152my $queue_root; 153{ 154 my $config_file = "/etc/mail/sendmail.cf"; 155 if (defined $opts{C}) 156 { 157 $config_file = $opts{C}; 158 } 159 160 my $line; 161 open(CONFIG_FILE, $config_file) or die "$config_file: $!"; 162 163 ## Notice: we can only break out of this loop (using last) 164 ## when both entries (queue directory and group group) 165 ## have been found. 166 while ($line = <CONFIG_FILE>) 167 { 168 chomp $line; 169 if ($line =~ m/^O QueueDirectory=(.*)/) 170 { 171 $queue_root = $1; 172 if ($queue_root =~ m/(.*)\/[^\/]+\*$/) 173 { 174 $queue_root = $1; 175 } 176 # found also queue groups? 177 if ($queuegroups) 178 { 179 last; 180 } 181 } 182 if ($line =~ m/^Q.*/) 183 { 184 $queuegroups = 1; 185 if ($action == \&move_action) 186 { 187 print("WARNING: moving queue files around " . 188 "when queue groups are used may\n" . 189 "result in undelivered mail!\n"); 190 } 191 # found also queue directory? 192 if (defined $queue_root) 193 { 194 last; 195 } 196 } 197 } 198 close(CONFIG_FILE); 199 if (!defined $queue_root) 200 { 201 die "QueueDirectory option not defined in $config_file"; 202 } 203} 204 205while (@ARGV) 206{ 207 $source_name = shift(@ARGV); 208 $result = add_source(\%sources, $source_name); 209 if ($result) 210 { 211 print("$result.\n"); 212 exit; 213 } 214} 215 216if (keys(%sources) == 0) 217{ 218 exit; 219} 220 221while (($source_name, $source) = each(%sources)) 222{ 223 $result = $conditions->check_move($source, $destination); 224 if ($result) 225 { 226 $result = &{$action}($source, $destination); 227 if ($result) 228 { 229 print("$result\n"); 230 } 231 } 232} 233 234sub usage 235{ 236 print("Usage:\t$0 [options] directory source ...\n"); 237 print("\t$0 [-Q][-d|-b] source ...\n"); 238 print("Options:\n"); 239 print("\t-b\t\tBounce the messages specified by source.\n"); 240 print("\t-C configfile\tSpecify sendmail config file.\n"); 241 print("\t-d\t\tDelete the messages specified by source.\n"); 242 print("\t-e [perl expression]\n"); 243 print("\t\t\tMove only messages for which perl expression\n"); 244 print("\t\t\treturns true.\n"); 245 print("\t-Q\t\tOperate on quarantined files.\n"); 246 print("\t-s [seconds]\tMove only messages whose queue file is older\n"); 247 print("\t\t\tthan seconds.\n"); 248} 249 250## 251## ADD_SOURCE -- Adds a source to the source hash. 252## 253## Determines whether source is a file, directory, or id. Then it 254## creates a QueuedMessage or Queue for that source and adds it to the 255## list. 256## 257## Parameters: 258## sources -- A hash that contains all of the sources. 259## source_name -- The name of the source to add 260## 261## Returns: 262## error_string -- Undef if ok. Error string otherwise. 263## 264## Notes: 265## If a new source comes in with the same ID as a previous 266## source, the previous source gets overwritten in the sources 267## hash. This lets the user specify things like * and it still 268## works nicely. 269## 270 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_name -- 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 = (split(/\?/, $line,3))[2]; 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 initialized 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 available 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