164562Sgshapiro#!/usr/bin/env perl 264562Sgshapiro## 3261363Sgshapiro## Copyright (c) 1998-2002 Proofpoint, Inc. and its suppliers. 490792Sgshapiro## All rights reserved. 564562Sgshapiro## 6266692Sgshapiro## $Id: qtool.pl,v 8.32 2013-11-22 20:51:18 ca Exp $ 764562Sgshapiro## 864562Sgshapirouse strict; 964562Sgshapirouse File::Basename; 1064562Sgshapirouse File::Copy; 1164562Sgshapirouse File::Spec; 1264562Sgshapirouse Fcntl qw(:flock :DEFAULT); 1364562Sgshapirouse Getopt::Std; 1464562Sgshapiro 1564562Sgshapiro## 1664562Sgshapiro## QTOOL 1764562Sgshapiro## This program is for moving files between sendmail queues. It is 1864562Sgshapiro## pretty similar to just moving the files manually, but it locks the files 1964562Sgshapiro## the same way sendmail does to prevent problems. 2064562Sgshapiro## 2194334Sgshapiro## NOTICE: Do not use this program to move queue files around 2294334Sgshapiro## if you use sendmail 8.12 and multiple queue groups. It may interfere 2394334Sgshapiro## with sendmail's internal queue group selection strategy and can cause 2494334Sgshapiro## mail to be not delivered. 2594334Sgshapiro## 2664562Sgshapiro## The syntax is the reverse of mv (ie. the target argument comes 2764562Sgshapiro## first). This lets you pick the files you want to move using find and 2864562Sgshapiro## xargs. 2964562Sgshapiro## 3064562Sgshapiro## Since you cannot delete queues while sendmail is running, QTOOL 3164562Sgshapiro## assumes that when you specify a directory as a source, you mean that you 3264562Sgshapiro## want all of the queue files within that directory moved, not the 3364562Sgshapiro## directory itself. 3464562Sgshapiro## 3564562Sgshapiro## There is a mechanism for adding conditionals for moving the files. 3664562Sgshapiro## Just create an Object with a check_move(source, dest) method and add it 3764562Sgshapiro## to the $conditions object. See the handling of the '-s' option for an 3864562Sgshapiro## example. 3964562Sgshapiro## 4064562Sgshapiro 4164562Sgshapiro## 4264562Sgshapiro## OPTION NOTES 4364562Sgshapiro## 4464562Sgshapiro## The -e option: 4564562Sgshapiro## The -e option takes any valid perl expression and evaluates it 4664562Sgshapiro## using the eval() function. Inside the expression the variable 4764562Sgshapiro## '$msg' is bound to the ControlFile object for the current source 4864562Sgshapiro## queue message. This lets you check for any value in the message 4964562Sgshapiro## headers or the control file. Here's an example: 5064562Sgshapiro## 5190792Sgshapiro## ./qtool.pl -e '$msg{num_delivery_attempts} >= 2' /q1 /q2 5264562Sgshapiro## 5364562Sgshapiro## This would move any queue files whose number of delivery attempts 5464562Sgshapiro## is greater than or equal to 2 from the queue 'q2' to the queue 'q1'. 5564562Sgshapiro## 5664562Sgshapiro## See the function ControlFile::parse for a list of available 5764562Sgshapiro## variables. 5864562Sgshapiro## 5964562Sgshapiro 6064562Sgshapiromy %opts; 6164562Sgshapiromy %sources; 6264562Sgshapiromy $dst_name; 6364562Sgshapiromy $destination; 6464562Sgshapiromy $source_name; 6564562Sgshapiromy $source; 6664562Sgshapiromy $result; 6764562Sgshapiromy $action; 6864562Sgshapiromy $new_condition; 6990792Sgshapiromy $qprefix; 7094334Sgshapiromy $queuegroups = 0; 7164562Sgshapiromy $conditions = new Compound(); 72168515Sgshapiromy $fcntl_struct = 's H60'; 73168515Sgshapiromy $fcntl_structlockp = pack($fcntl_struct, Fcntl::F_WRLCK, 74168515Sgshapiro "000000000000000000000000000000000000000000000000000000000000"); 75168515Sgshapiromy $fcntl_structunlockp = pack($fcntl_struct, Fcntl::F_UNLCK, 76168515Sgshapiro "000000000000000000000000000000000000000000000000000000000000"); 77168515Sgshapiromy $lock_both = -1; 7864562Sgshapiro 7990792SgshapiroGetopt::Std::getopts('bC:de:Qs:', \%opts); 8064562Sgshapiro 8164562Sgshapirosub move_action 8264562Sgshapiro{ 8364562Sgshapiro my $source = shift; 8464562Sgshapiro my $destination = shift; 8564562Sgshapiro 8664562Sgshapiro $result = $destination->add($source); 8764562Sgshapiro if ($result) 8864562Sgshapiro { 8964562Sgshapiro print("$result.\n"); 9064562Sgshapiro } 9164562Sgshapiro} 9264562Sgshapiro 9364562Sgshapirosub delete_action 9464562Sgshapiro{ 9564562Sgshapiro my $source = shift; 9664562Sgshapiro 9764562Sgshapiro return $source->delete(); 9864562Sgshapiro} 9964562Sgshapiro 10064562Sgshapirosub bounce_action 10164562Sgshapiro{ 10264562Sgshapiro my $source = shift; 10364562Sgshapiro 10464562Sgshapiro return $source->bounce(); 10564562Sgshapiro} 10664562Sgshapiro 10764562Sgshapiro$action = \&move_action; 10864562Sgshapiroif (defined $opts{d}) 10964562Sgshapiro{ 11064562Sgshapiro $action = \&delete_action; 11164562Sgshapiro} 11264562Sgshapiroelsif (defined $opts{b}) 11364562Sgshapiro{ 11464562Sgshapiro $action = \&bounce_action; 11564562Sgshapiro} 11664562Sgshapiro 11764562Sgshapiroif (defined $opts{s}) 11864562Sgshapiro{ 11964562Sgshapiro $new_condition = new OlderThan($opts{s}); 12064562Sgshapiro $conditions->add($new_condition); 12164562Sgshapiro} 12264562Sgshapiro 12364562Sgshapiroif (defined $opts{e}) 12464562Sgshapiro{ 12564562Sgshapiro $new_condition = new Eval($opts{e}); 12664562Sgshapiro $conditions->add($new_condition); 12764562Sgshapiro} 12864562Sgshapiro 12990792Sgshapiroif (defined $opts{Q}) 13090792Sgshapiro{ 13190792Sgshapiro $qprefix = "hf"; 13290792Sgshapiro} 13390792Sgshapiroelse 13490792Sgshapiro{ 13590792Sgshapiro $qprefix = "qf"; 13690792Sgshapiro} 13790792Sgshapiro 13864562Sgshapiroif ($action == \&move_action) 13964562Sgshapiro{ 14064562Sgshapiro $dst_name = shift(@ARGV); 14164562Sgshapiro if (!-d $dst_name) 14264562Sgshapiro { 14364562Sgshapiro print("The destination '$dst_name' must be an existing " . 14464562Sgshapiro "directory.\n"); 14564562Sgshapiro usage(); 14664562Sgshapiro exit; 14764562Sgshapiro } 14864562Sgshapiro $destination = new Queue($dst_name); 14964562Sgshapiro} 15064562Sgshapiro 15190792Sgshapiro# determine queue_root by reading config file 15290792Sgshapiromy $queue_root; 15390792Sgshapiro{ 15490792Sgshapiro my $config_file = "/etc/mail/sendmail.cf"; 15590792Sgshapiro if (defined $opts{C}) 15690792Sgshapiro { 15790792Sgshapiro $config_file = $opts{C}; 15890792Sgshapiro } 15990792Sgshapiro 16090792Sgshapiro my $line; 16190792Sgshapiro open(CONFIG_FILE, $config_file) or die "$config_file: $!"; 16294334Sgshapiro 16394334Sgshapiro ## Notice: we can only break out of this loop (using last) 16494334Sgshapiro ## when both entries (queue directory and group group) 16594334Sgshapiro ## have been found. 16690792Sgshapiro while ($line = <CONFIG_FILE>) 16790792Sgshapiro { 16890792Sgshapiro chomp $line; 16990792Sgshapiro if ($line =~ m/^O QueueDirectory=(.*)/) 17090792Sgshapiro { 17190792Sgshapiro $queue_root = $1; 17290792Sgshapiro if ($queue_root =~ m/(.*)\/[^\/]+\*$/) 17390792Sgshapiro { 17490792Sgshapiro $queue_root = $1; 17590792Sgshapiro } 17694334Sgshapiro # found also queue groups? 17794334Sgshapiro if ($queuegroups) 17894334Sgshapiro { 17994334Sgshapiro last; 18094334Sgshapiro } 18190792Sgshapiro } 18294334Sgshapiro if ($line =~ m/^Q.*/) 18394334Sgshapiro { 18494334Sgshapiro $queuegroups = 1; 18594334Sgshapiro if ($action == \&move_action) 18694334Sgshapiro { 18794334Sgshapiro print("WARNING: moving queue files around " . 18894334Sgshapiro "when queue groups are used may\n" . 18994334Sgshapiro "result in undelivered mail!\n"); 19094334Sgshapiro } 19194334Sgshapiro # found also queue directory? 19294334Sgshapiro if (defined $queue_root) 19394334Sgshapiro { 19494334Sgshapiro last; 19594334Sgshapiro } 19694334Sgshapiro } 19790792Sgshapiro } 19890792Sgshapiro close(CONFIG_FILE); 19990792Sgshapiro if (!defined $queue_root) 20090792Sgshapiro { 20190792Sgshapiro die "QueueDirectory option not defined in $config_file"; 20290792Sgshapiro } 20390792Sgshapiro} 20490792Sgshapiro 20564562Sgshapirowhile (@ARGV) 20664562Sgshapiro{ 20764562Sgshapiro $source_name = shift(@ARGV); 20864562Sgshapiro $result = add_source(\%sources, $source_name); 20964562Sgshapiro if ($result) 21064562Sgshapiro { 21164562Sgshapiro print("$result.\n"); 21271345Sgshapiro exit; 21364562Sgshapiro } 21464562Sgshapiro} 21564562Sgshapiro 21664562Sgshapiroif (keys(%sources) == 0) 21764562Sgshapiro{ 21864562Sgshapiro exit; 21964562Sgshapiro} 22064562Sgshapiro 22164562Sgshapirowhile (($source_name, $source) = each(%sources)) 22264562Sgshapiro{ 22364562Sgshapiro $result = $conditions->check_move($source, $destination); 22464562Sgshapiro if ($result) 22564562Sgshapiro { 22664562Sgshapiro $result = &{$action}($source, $destination); 22764562Sgshapiro if ($result) 22864562Sgshapiro { 22964562Sgshapiro print("$result\n"); 23064562Sgshapiro } 23164562Sgshapiro } 23264562Sgshapiro} 23364562Sgshapiro 23464562Sgshapirosub usage 23564562Sgshapiro{ 23690792Sgshapiro print("Usage:\t$0 [options] directory source ...\n"); 23790792Sgshapiro print("\t$0 [-Q][-d|-b] source ...\n"); 23890792Sgshapiro print("Options:\n"); 23990792Sgshapiro print("\t-b\t\tBounce the messages specified by source.\n"); 24090792Sgshapiro print("\t-C configfile\tSpecify sendmail config file.\n"); 24190792Sgshapiro print("\t-d\t\tDelete the messages specified by source.\n"); 24290792Sgshapiro print("\t-e [perl expression]\n"); 24390792Sgshapiro print("\t\t\tMove only messages for which perl expression\n"); 24490792Sgshapiro print("\t\t\treturns true.\n"); 24590792Sgshapiro print("\t-Q\t\tOperate on quarantined files.\n"); 24690792Sgshapiro print("\t-s [seconds]\tMove only messages whose queue file is older\n"); 24790792Sgshapiro print("\t\t\tthan seconds.\n"); 24864562Sgshapiro} 24964562Sgshapiro 25064562Sgshapiro## 25164562Sgshapiro## ADD_SOURCE -- Adds a source to the source hash. 25264562Sgshapiro## 25364562Sgshapiro## Determines whether source is a file, directory, or id. Then it 25464562Sgshapiro## creates a QueuedMessage or Queue for that source and adds it to the 25564562Sgshapiro## list. 25664562Sgshapiro## 25764562Sgshapiro## Parameters: 25864562Sgshapiro## sources -- A hash that contains all of the sources. 25964562Sgshapiro## source_name -- The name of the source to add 26064562Sgshapiro## 26164562Sgshapiro## Returns: 26264562Sgshapiro## error_string -- Undef if ok. Error string otherwise. 26364562Sgshapiro## 26464562Sgshapiro## Notes: 26564562Sgshapiro## If a new source comes in with the same ID as a previous 26664562Sgshapiro## source, the previous source gets overwritten in the sources 26764562Sgshapiro## hash. This lets the user specify things like * and it still 26864562Sgshapiro## works nicely. 26964562Sgshapiro## 27064562Sgshapiro 27164562Sgshapirosub add_source 27264562Sgshapiro{ 27364562Sgshapiro my $sources = shift; 27464562Sgshapiro my $source_name = shift; 27564562Sgshapiro my $source_base_name; 27664562Sgshapiro my $source_dir_name; 27764562Sgshapiro my $data_dir_name; 27864562Sgshapiro my $source_id; 27964562Sgshapiro my $source_prefix; 28064562Sgshapiro my $queued_message; 28164562Sgshapiro my $queue; 28264562Sgshapiro my $result; 28364562Sgshapiro 28464562Sgshapiro ($source_base_name, $source_dir_name) = File::Basename::fileparse($source_name); 28564562Sgshapiro $data_dir_name = $source_dir_name; 28664562Sgshapiro 28764562Sgshapiro $source_prefix = substr($source_base_name, 0, 2); 28890792Sgshapiro if (!-d $source_name && $source_prefix ne $qprefix && 28964562Sgshapiro $source_prefix ne 'df') 29064562Sgshapiro { 29190792Sgshapiro $source_base_name = "$qprefix$source_base_name"; 29264562Sgshapiro $source_name = File::Spec->catfile("$source_dir_name", 29364562Sgshapiro "$source_base_name"); 29464562Sgshapiro } 29564562Sgshapiro $source_id = substr($source_base_name, 2); 29664562Sgshapiro 29764562Sgshapiro if (!-e $source_name) 29864562Sgshapiro { 29964562Sgshapiro $source_name = File::Spec->catfile("$source_dir_name", "qf", 30090792Sgshapiro "$qprefix$source_id"); 30164562Sgshapiro if (!-e $source_name) 30264562Sgshapiro { 30364562Sgshapiro return "'$source_name' does not exist"; 30464562Sgshapiro } 30564562Sgshapiro $data_dir_name = File::Spec->catfile("$source_dir_name", "df"); 30690792Sgshapiro if (!-d $data_dir_name) 30790792Sgshapiro { 30890792Sgshapiro $data_dir_name = $source_dir_name; 30990792Sgshapiro } 31064562Sgshapiro $source_dir_name = File::Spec->catfile("$source_dir_name", 31164562Sgshapiro "qf"); 31264562Sgshapiro } 31364562Sgshapiro 31464562Sgshapiro if (-f $source_name) 31564562Sgshapiro { 31664562Sgshapiro $queued_message = new QueuedMessage($source_dir_name, 31764562Sgshapiro $source_id, 31864562Sgshapiro $data_dir_name); 31964562Sgshapiro $sources->{$source_id} = $queued_message; 32064562Sgshapiro return undef; 32164562Sgshapiro } 32264562Sgshapiro 32364562Sgshapiro if (!-d $source_name) 32464562Sgshapiro { 32564562Sgshapiro return "'$source_name' is not a plain file or a directory"; 32664562Sgshapiro } 32764562Sgshapiro 32864562Sgshapiro $queue = new Queue($source_name); 32964562Sgshapiro $result = $queue->read(); 33064562Sgshapiro if ($result) 33164562Sgshapiro { 33264562Sgshapiro return $result; 33364562Sgshapiro } 33464562Sgshapiro 33564562Sgshapiro while (($source_id, $queued_message) = each(%{$queue->{files}})) 33664562Sgshapiro { 33764562Sgshapiro $sources->{$source_id} = $queued_message; 33864562Sgshapiro } 33964562Sgshapiro 34064562Sgshapiro return undef; 34164562Sgshapiro} 34264562Sgshapiro 34364562Sgshapiro## 34464562Sgshapiro## LOCK_FILE -- Opens and then locks a file. 34564562Sgshapiro## 34664562Sgshapiro## Opens a file for read/write and uses flock to obtain a lock on the 34764562Sgshapiro## file. The flock is Perl's flock which defaults to flock on systems 34864562Sgshapiro## that support it. On systems without flock it falls back to fcntl 349168515Sgshapiro## locking. This script will also call fcntl explicitly if flock 350168515Sgshapiro## uses BSD semantics (i.e. if both flock() and fcntl() can successfully 351168515Sgshapiro## lock the file at the same time) 35264562Sgshapiro## 35364562Sgshapiro## Parameters: 35464562Sgshapiro## file_name -- The name of the file to open and lock. 35564562Sgshapiro## 35664562Sgshapiro## Returns: 35764562Sgshapiro## (file_handle, error_string) -- If everything works then 35864562Sgshapiro## file_handle is a reference to a file handle and 35964562Sgshapiro## error_string is undef. If there is a problem then 36064562Sgshapiro## file_handle is undef and error_string is a string 36164562Sgshapiro## explaining the problem. 36264562Sgshapiro## 36364562Sgshapiro 36464562Sgshapirosub lock_file 36564562Sgshapiro{ 36664562Sgshapiro my $file_name = shift; 36764562Sgshapiro my $result; 36864562Sgshapiro 369168515Sgshapiro if ($lock_both == -1) 370168515Sgshapiro { 371168515Sgshapiro if (open(DEVNULL, '>/dev/null')) 372168515Sgshapiro { 373168515Sgshapiro my $flock_status = flock(DEVNULL, Fcntl::LOCK_EX | Fcntl::LOCK_NB); 374168515Sgshapiro my $fcntl_status = fcntl (DEVNULL, Fcntl::F_SETLK, $fcntl_structlockp); 375168515Sgshapiro close(DEVNULL); 376168515Sgshapiro 377168515Sgshapiro $lock_both = ($flock_status && $fcntl_status); 378168515Sgshapiro } 379168515Sgshapiro else 380168515Sgshapiro { 381168515Sgshapiro # Couldn't open /dev/null. Windows system? 382168515Sgshapiro $lock_both = 0; 383168515Sgshapiro } 384168515Sgshapiro } 385168515Sgshapiro 386168515Sgshapiro 38764562Sgshapiro $result = sysopen(FILE_TO_LOCK, $file_name, Fcntl::O_RDWR); 38864562Sgshapiro if (!$result) 38964562Sgshapiro { 39064562Sgshapiro return (undef, "Unable to open '$file_name': $!"); 39164562Sgshapiro } 39264562Sgshapiro 39364562Sgshapiro $result = flock(FILE_TO_LOCK, Fcntl::LOCK_EX | Fcntl::LOCK_NB); 39464562Sgshapiro if (!$result) 39564562Sgshapiro { 39664562Sgshapiro return (undef, "Could not obtain lock on '$file_name': $!"); 39764562Sgshapiro } 39864562Sgshapiro 399168515Sgshapiro if ($lock_both) 400168515Sgshapiro { 401168515Sgshapiro my $result2 = fcntl (FILE_TO_LOCK, Fcntl::F_SETLK, $fcntl_structlockp); 402168515Sgshapiro if (!$result2) 403168515Sgshapiro { 404168515Sgshapiro return (undef, "Could not obtain fcntl lock on '$file_name': $!"); 405168515Sgshapiro } 406168515Sgshapiro } 407168515Sgshapiro 40864562Sgshapiro return (\*FILE_TO_LOCK, undef); 40964562Sgshapiro} 41064562Sgshapiro 41164562Sgshapiro## 41264562Sgshapiro## UNLOCK_FILE -- Unlocks a file. 41364562Sgshapiro## 41464562Sgshapiro## Unlocks a file using Perl's flock. 41564562Sgshapiro## 41664562Sgshapiro## Parameters: 41764562Sgshapiro## file -- A file handle. 41864562Sgshapiro## 41964562Sgshapiro## Returns: 42064562Sgshapiro## error_string -- If undef then no problem. Otherwise it is a 42164562Sgshapiro## string that explains problem. 42264562Sgshapiro## 42364562Sgshapiro 42464562Sgshapirosub unlock_file 42564562Sgshapiro{ 42664562Sgshapiro my $file = shift; 42764562Sgshapiro my $result; 42864562Sgshapiro 42964562Sgshapiro $result = flock($file, Fcntl::LOCK_UN); 43064562Sgshapiro if (!$result) 43164562Sgshapiro { 43264562Sgshapiro return "Unlock failed on '$result': $!"; 43364562Sgshapiro } 434168515Sgshapiro if ($lock_both) 435168515Sgshapiro { 436168515Sgshapiro my $result2 = fcntl ($file, Fcntl::F_SETLK, $fcntl_structunlockp); 437168515Sgshapiro if (!$result2) 438168515Sgshapiro { 439168515Sgshapiro return (undef, "Fcntl unlock failed on '$result': $!"); 440168515Sgshapiro } 441168515Sgshapiro } 44264562Sgshapiro 44364562Sgshapiro return undef; 44464562Sgshapiro} 44564562Sgshapiro 44664562Sgshapiro## 44764562Sgshapiro## MOVE_FILE -- Moves a file. 44864562Sgshapiro## 44964562Sgshapiro## Moves a file. 45064562Sgshapiro## 45164562Sgshapiro## Parameters: 45264562Sgshapiro## src_name -- The name of the file to be move. 453203004Sgshapiro## dst_name -- The name of the place to move it to. 45464562Sgshapiro## 45564562Sgshapiro## Returns: 45664562Sgshapiro## error_string -- If undef then no problem. Otherwise it is a 45764562Sgshapiro## string that explains problem. 45864562Sgshapiro## 45964562Sgshapiro 46064562Sgshapirosub move_file 46164562Sgshapiro{ 46264562Sgshapiro my $src_name = shift; 46364562Sgshapiro my $dst_name = shift; 46464562Sgshapiro my $result; 46564562Sgshapiro 46664562Sgshapiro $result = File::Copy::move($src_name, $dst_name); 46764562Sgshapiro if (!$result) 46864562Sgshapiro { 46964562Sgshapiro return "File move from '$src_name' to '$dst_name' failed: $!"; 47064562Sgshapiro } 47164562Sgshapiro 47264562Sgshapiro return undef; 47364562Sgshapiro} 47464562Sgshapiro 47564562Sgshapiro 47664562Sgshapiro## 47764562Sgshapiro## CONTROL_FILE - Represents a sendmail queue control file. 47864562Sgshapiro## 47964562Sgshapiro## This object represents represents a sendmail queue control file. 48064562Sgshapiro## It can parse and lock its file. 48164562Sgshapiro## 48264562Sgshapiro 48364562Sgshapiro 48464562Sgshapiropackage ControlFile; 48564562Sgshapiro 48664562Sgshapirosub new 48764562Sgshapiro{ 48864562Sgshapiro my $this = shift; 48964562Sgshapiro my $class = ref($this) || $this; 49064562Sgshapiro my $self = {}; 49164562Sgshapiro bless $self, $class; 49264562Sgshapiro $self->initialize(@_); 49364562Sgshapiro return $self; 49464562Sgshapiro} 49564562Sgshapiro 49664562Sgshapirosub initialize 49764562Sgshapiro{ 49864562Sgshapiro my $self = shift; 49964562Sgshapiro my $queue_dir = shift; 50064562Sgshapiro $self->{id} = shift; 50164562Sgshapiro 50290792Sgshapiro $self->{file_name} = $queue_dir . '/' . $qprefix . $self->{id}; 50364562Sgshapiro $self->{headers} = {}; 50464562Sgshapiro} 50564562Sgshapiro 50664562Sgshapiro## 50764562Sgshapiro## PARSE - Parses the control file. 50864562Sgshapiro## 50964562Sgshapiro## Parses the control file. It just sticks each entry into a hash. 51064562Sgshapiro## If a key has more than one entry, then it points to a list of 51164562Sgshapiro## entries. 51264562Sgshapiro## 51364562Sgshapiro 51464562Sgshapirosub parse 51564562Sgshapiro{ 51664562Sgshapiro my $self = shift; 51764562Sgshapiro if ($self->{parsed}) 51864562Sgshapiro { 51964562Sgshapiro return; 52064562Sgshapiro } 52164562Sgshapiro my %parse_table = 52264562Sgshapiro ( 52364562Sgshapiro 'A' => 'auth', 52464562Sgshapiro 'B' => 'body_type', 52564562Sgshapiro 'C' => 'controlling_user', 52664562Sgshapiro 'D' => 'data_file_name', 52790792Sgshapiro 'd' => 'data_file_directory', 52864562Sgshapiro 'E' => 'error_recipient', 52964562Sgshapiro 'F' => 'flags', 53064562Sgshapiro 'H' => 'parse_header', 53164562Sgshapiro 'I' => 'inode_number', 53264562Sgshapiro 'K' => 'next_delivery_time', 53364562Sgshapiro 'L' => 'content-length', 53464562Sgshapiro 'M' => 'message', 53564562Sgshapiro 'N' => 'num_delivery_attempts', 53664562Sgshapiro 'P' => 'priority', 53764562Sgshapiro 'Q' => 'original_recipient', 53864562Sgshapiro 'R' => 'recipient', 53990792Sgshapiro 'q' => 'quarantine_reason', 54090792Sgshapiro 'r' => 'final_recipient', 54164562Sgshapiro 'S' => 'sender', 54264562Sgshapiro 'T' => 'creation_time', 54364562Sgshapiro 'V' => 'version', 54490792Sgshapiro 'Y' => 'current_delay', 54564562Sgshapiro 'Z' => 'envid', 54690792Sgshapiro '!' => 'deliver_by', 54764562Sgshapiro '$' => 'macro' 54864562Sgshapiro ); 54964562Sgshapiro my $line; 55064562Sgshapiro my $line_type; 55164562Sgshapiro my $line_value; 55264562Sgshapiro my $member_name; 55364562Sgshapiro my $member; 55464562Sgshapiro my $last_type; 55564562Sgshapiro 55664562Sgshapiro open(CONTROL_FILE, "$self->{file_name}"); 55764562Sgshapiro while ($line = <CONTROL_FILE>) 55864562Sgshapiro { 55964562Sgshapiro $line_type = substr($line, 0, 1); 56064562Sgshapiro if ($line_type eq "\t" && $last_type eq 'H') 56164562Sgshapiro { 56264562Sgshapiro $line_type = 'H'; 56364562Sgshapiro $line_value = $line; 56464562Sgshapiro } 56564562Sgshapiro else 56664562Sgshapiro { 56764562Sgshapiro $line_value = substr($line, 1); 56864562Sgshapiro } 56964562Sgshapiro $member_name = $parse_table{$line_type}; 57064562Sgshapiro $last_type = $line_type; 57164562Sgshapiro if (!$member_name) 57264562Sgshapiro { 57364562Sgshapiro $member_name = 'unknown'; 57464562Sgshapiro } 57564562Sgshapiro if ($self->can($member_name)) 57664562Sgshapiro { 57764562Sgshapiro $self->$member_name($line_value); 57864562Sgshapiro } 57964562Sgshapiro $member = $self->{$member_name}; 58064562Sgshapiro if (!$member) 58164562Sgshapiro { 58264562Sgshapiro $self->{$member_name} = $line_value; 58364562Sgshapiro next; 58464562Sgshapiro } 58564562Sgshapiro if (ref($member) eq 'ARRAY') 58664562Sgshapiro { 58764562Sgshapiro push(@{$member}, $line_value); 58864562Sgshapiro next; 58964562Sgshapiro } 59064562Sgshapiro $self->{$member_name} = [$member, $line_value]; 59164562Sgshapiro } 59264562Sgshapiro close(CONTROL_FILE); 59364562Sgshapiro 59464562Sgshapiro $self->{parsed} = 1; 59564562Sgshapiro} 59664562Sgshapiro 59764562Sgshapirosub parse_header 59864562Sgshapiro{ 59964562Sgshapiro my $self = shift; 60064562Sgshapiro my $line = shift; 60164562Sgshapiro my $headers = $self->{headers}; 60264562Sgshapiro my $last_header = $self->{last_header}; 60364562Sgshapiro my $header_name; 60464562Sgshapiro my $header_value; 60564562Sgshapiro my $first_char; 60664562Sgshapiro 60764562Sgshapiro $first_char = substr($line, 0, 1); 60864562Sgshapiro if ($first_char eq "?") 60964562Sgshapiro { 610223067Sgshapiro $line = (split(/\?/, $line,3))[2]; 61164562Sgshapiro } 61264562Sgshapiro elsif ($first_char eq "\t") 61364562Sgshapiro { 61464562Sgshapiro if (ref($headers->{$last_header}) eq 'ARRAY') 61564562Sgshapiro { 61664562Sgshapiro $headers->{$last_header}[-1] = 61790792Sgshapiro $headers->{$last_header}[-1] . $line; 61864562Sgshapiro } 61964562Sgshapiro else 62064562Sgshapiro { 62164562Sgshapiro $headers->{$last_header} = $headers->{$last_header} . 62264562Sgshapiro $line; 62364562Sgshapiro } 62464562Sgshapiro return; 62564562Sgshapiro } 62664562Sgshapiro ($header_name, $header_value) = split(/:/, $line, 2); 62764562Sgshapiro $self->{last_header} = $header_name; 62864562Sgshapiro if (exists $headers->{$header_name}) 62964562Sgshapiro { 63064562Sgshapiro $headers->{$header_name} = [$headers->{$header_name}, 63164562Sgshapiro $header_value]; 63264562Sgshapiro } 63364562Sgshapiro else 63464562Sgshapiro { 63564562Sgshapiro $headers->{$header_name} = $header_value; 63664562Sgshapiro } 63764562Sgshapiro} 63864562Sgshapiro 63964562Sgshapirosub is_locked 64064562Sgshapiro{ 64164562Sgshapiro my $self = shift; 64264562Sgshapiro 64364562Sgshapiro return (defined $self->{lock_handle}); 64464562Sgshapiro} 64564562Sgshapiro 64664562Sgshapirosub lock 64764562Sgshapiro{ 64864562Sgshapiro my $self = shift; 64964562Sgshapiro my $lock_handle; 65064562Sgshapiro my $result; 65164562Sgshapiro 65264562Sgshapiro if ($self->is_locked()) 65364562Sgshapiro { 65464562Sgshapiro # Already locked 65564562Sgshapiro return undef; 65664562Sgshapiro } 65764562Sgshapiro 65864562Sgshapiro ($lock_handle, $result) = ::lock_file($self->{file_name}); 65964562Sgshapiro if (!$lock_handle) 66064562Sgshapiro { 66164562Sgshapiro return $result; 66264562Sgshapiro } 66364562Sgshapiro 66464562Sgshapiro $self->{lock_handle} = $lock_handle; 66564562Sgshapiro 66664562Sgshapiro return undef; 66764562Sgshapiro} 66864562Sgshapiro 66964562Sgshapirosub unlock 67064562Sgshapiro{ 67164562Sgshapiro my $self = shift; 67264562Sgshapiro my $result; 67364562Sgshapiro 67464562Sgshapiro if (!$self->is_locked()) 67564562Sgshapiro { 67664562Sgshapiro # Not locked 67764562Sgshapiro return undef; 67864562Sgshapiro } 67964562Sgshapiro 68064562Sgshapiro $result = ::unlock_file($self->{lock_handle}); 68164562Sgshapiro 68264562Sgshapiro $self->{lock_handle} = undef; 68364562Sgshapiro 68464562Sgshapiro return $result; 68564562Sgshapiro} 68664562Sgshapiro 68764562Sgshapirosub do_stat 68864562Sgshapiro{ 68964562Sgshapiro my $self = shift; 69064562Sgshapiro my $result; 69164562Sgshapiro my @result; 69264562Sgshapiro 69364562Sgshapiro $result = open(QUEUE_FILE, $self->{file_name}); 69464562Sgshapiro if (!$result) 69564562Sgshapiro { 69664562Sgshapiro return "Unable to open '$self->{file_name}': $!"; 69764562Sgshapiro } 69864562Sgshapiro @result = stat(QUEUE_FILE); 69964562Sgshapiro if (!@result) 70064562Sgshapiro { 70164562Sgshapiro return "Unable to stat '$self->{file_name}': $!"; 70264562Sgshapiro } 70364562Sgshapiro $self->{control_size} = $result[7]; 70464562Sgshapiro $self->{control_last_mod_time} = $result[9]; 70564562Sgshapiro} 70664562Sgshapiro 70764562Sgshapirosub DESTROY 70864562Sgshapiro{ 70964562Sgshapiro my $self = shift; 71064562Sgshapiro 71164562Sgshapiro $self->unlock(); 71264562Sgshapiro} 71364562Sgshapiro 71464562Sgshapirosub delete 71564562Sgshapiro{ 71664562Sgshapiro my $self = shift; 71764562Sgshapiro my $result; 71864562Sgshapiro 71964562Sgshapiro $result = unlink($self->{file_name}); 72064562Sgshapiro if (!$result) 72164562Sgshapiro { 72264562Sgshapiro return "Unable to delete $self->{file_name}: $!"; 72364562Sgshapiro } 72464562Sgshapiro return undef; 72564562Sgshapiro} 72664562Sgshapiro 72764562Sgshapiro 72864562Sgshapiro## 72964562Sgshapiro## DATA_FILE - Represents a sendmail queue data file. 73064562Sgshapiro## 73164562Sgshapiro## This object represents represents a sendmail queue data file. 73264562Sgshapiro## It is really just a place-holder. 73364562Sgshapiro## 73464562Sgshapiro 73564562Sgshapiropackage DataFile; 73664562Sgshapiro 73764562Sgshapirosub new 73864562Sgshapiro{ 73964562Sgshapiro my $this = shift; 74064562Sgshapiro my $class = ref($this) || $this; 74164562Sgshapiro my $self = {}; 74264562Sgshapiro bless $self, $class; 74364562Sgshapiro $self->initialize(@_); 74464562Sgshapiro return $self; 74564562Sgshapiro} 74664562Sgshapiro 74764562Sgshapirosub initialize 74864562Sgshapiro{ 74964562Sgshapiro my $self = shift; 75090792Sgshapiro my $data_dir = shift; 75164562Sgshapiro $self->{id} = shift; 75290792Sgshapiro my $control_file = shift; 75364562Sgshapiro 75490792Sgshapiro $self->{file_name} = $data_dir . '/df' . $self->{id}; 75590792Sgshapiro return if -e $self->{file_name}; 75690792Sgshapiro $control_file->parse(); 75790792Sgshapiro return if !defined $control_file->{data_file_directory}; 75890792Sgshapiro $data_dir = $queue_root . '/' . $control_file->{data_file_directory}; 75990792Sgshapiro chomp $data_dir; 76090792Sgshapiro if (-d ($data_dir . '/df')) 76190792Sgshapiro { 76290792Sgshapiro $data_dir .= '/df'; 76390792Sgshapiro } 76490792Sgshapiro $self->{file_name} = $data_dir . '/df' . $self->{id}; 76564562Sgshapiro} 76664562Sgshapiro 76764562Sgshapirosub do_stat 76864562Sgshapiro{ 76964562Sgshapiro my $self = shift; 77064562Sgshapiro my $result; 77164562Sgshapiro my @result; 77264562Sgshapiro 77364562Sgshapiro $result = open(QUEUE_FILE, $self->{file_name}); 77464562Sgshapiro if (!$result) 77564562Sgshapiro { 77664562Sgshapiro return "Unable to open '$self->{file_name}': $!"; 77764562Sgshapiro } 77864562Sgshapiro @result = stat(QUEUE_FILE); 77964562Sgshapiro if (!@result) 78064562Sgshapiro { 78164562Sgshapiro return "Unable to stat '$self->{file_name}': $!"; 78264562Sgshapiro } 78364562Sgshapiro $self->{body_size} = $result[7]; 78464562Sgshapiro $self->{body_last_mod_time} = $result[9]; 78564562Sgshapiro} 78664562Sgshapiro 78764562Sgshapirosub delete 78864562Sgshapiro{ 78964562Sgshapiro my $self = shift; 79064562Sgshapiro my $result; 79164562Sgshapiro 79264562Sgshapiro $result = unlink($self->{file_name}); 79364562Sgshapiro if (!$result) 79464562Sgshapiro { 79564562Sgshapiro return "Unable to delete $self->{file_name}: $!"; 79664562Sgshapiro } 79764562Sgshapiro return undef; 79864562Sgshapiro} 79964562Sgshapiro 80064562Sgshapiro 80164562Sgshapiro## 80264562Sgshapiro## QUEUED_MESSAGE - Represents a queued sendmail message. 80364562Sgshapiro## 80464562Sgshapiro## This keeps track of the files that make up a queued sendmail 80564562Sgshapiro## message. 80664562Sgshapiro## Currently it has 'control_file' and 'data_file' as members. 80764562Sgshapiro## 80864562Sgshapiro## You can tie it to a fetch only hash using tie. You need to 80964562Sgshapiro## pass a reference to a QueuedMessage as the third argument 81064562Sgshapiro## to tie. 81164562Sgshapiro## 81264562Sgshapiro 81364562Sgshapiropackage QueuedMessage; 81464562Sgshapiro 81564562Sgshapirosub new 81664562Sgshapiro{ 81764562Sgshapiro my $this = shift; 81864562Sgshapiro my $class = ref($this) || $this; 81964562Sgshapiro my $self = {}; 82064562Sgshapiro bless $self, $class; 82164562Sgshapiro $self->initialize(@_); 82264562Sgshapiro return $self; 82364562Sgshapiro} 82464562Sgshapiro 82564562Sgshapirosub initialize 82664562Sgshapiro{ 82764562Sgshapiro my $self = shift; 82864562Sgshapiro my $queue_dir = shift; 82964562Sgshapiro my $id = shift; 83064562Sgshapiro my $data_dir = shift; 83164562Sgshapiro 83264562Sgshapiro $self->{id} = $id; 83364562Sgshapiro $self->{control_file} = new ControlFile($queue_dir, $id); 83490792Sgshapiro if (!$data_dir) 83564562Sgshapiro { 83690792Sgshapiro $data_dir = $queue_dir; 83764562Sgshapiro } 83890792Sgshapiro $self->{data_file} = new DataFile($data_dir, $id, $self->{control_file}); 83964562Sgshapiro} 84064562Sgshapiro 84164562Sgshapirosub last_modified_time 84264562Sgshapiro{ 84364562Sgshapiro my $self = shift; 84464562Sgshapiro my @result; 84564562Sgshapiro @result = stat($self->{data_file}->{file_name}); 84664562Sgshapiro return $result[9]; 84764562Sgshapiro} 84864562Sgshapiro 84964562Sgshapirosub TIEHASH 85064562Sgshapiro{ 85164562Sgshapiro my $this = shift; 85264562Sgshapiro my $class = ref($this) || $this; 85364562Sgshapiro my $self = shift; 85464562Sgshapiro return $self; 85564562Sgshapiro} 85664562Sgshapiro 85764562Sgshapirosub FETCH 85864562Sgshapiro{ 85964562Sgshapiro my $self = shift; 86064562Sgshapiro my $key = shift; 86164562Sgshapiro 86264562Sgshapiro if (exists $self->{control_file}->{$key}) 86364562Sgshapiro { 86464562Sgshapiro return $self->{control_file}->{$key}; 86564562Sgshapiro } 86664562Sgshapiro if (exists $self->{data_file}->{$key}) 86764562Sgshapiro { 86864562Sgshapiro return $self->{data_file}->{$key}; 86964562Sgshapiro } 87064562Sgshapiro 87164562Sgshapiro return undef; 87264562Sgshapiro} 87364562Sgshapiro 87464562Sgshapirosub lock 87564562Sgshapiro{ 87664562Sgshapiro my $self = shift; 87764562Sgshapiro 87864562Sgshapiro return $self->{control_file}->lock(); 87964562Sgshapiro} 88064562Sgshapiro 88164562Sgshapirosub unlock 88264562Sgshapiro{ 88364562Sgshapiro my $self = shift; 88464562Sgshapiro 88564562Sgshapiro return $self->{control_file}->unlock(); 88664562Sgshapiro} 88764562Sgshapiro 88864562Sgshapirosub move 88964562Sgshapiro{ 89064562Sgshapiro my $self = shift; 89164562Sgshapiro my $destination = shift; 89264562Sgshapiro my $df_dest; 89364562Sgshapiro my $qf_dest; 89464562Sgshapiro my $result; 89564562Sgshapiro 89664562Sgshapiro $result = $self->lock(); 89764562Sgshapiro if ($result) 89864562Sgshapiro { 89964562Sgshapiro return $result; 90064562Sgshapiro } 90164562Sgshapiro 90264562Sgshapiro $qf_dest = File::Spec->catfile($destination, "qf"); 90364562Sgshapiro if (-d $qf_dest) 90464562Sgshapiro { 90564562Sgshapiro $df_dest = File::Spec->catfile($destination, "df"); 90664562Sgshapiro if (!-d $df_dest) 90764562Sgshapiro { 90864562Sgshapiro $df_dest = $destination; 90964562Sgshapiro } 91064562Sgshapiro } 91164562Sgshapiro else 91264562Sgshapiro { 91364562Sgshapiro $qf_dest = $destination; 91464562Sgshapiro $df_dest = $destination; 91564562Sgshapiro } 91664562Sgshapiro 91790792Sgshapiro if (-e File::Spec->catfile($qf_dest, "$qprefix$self->{id}")) 91864562Sgshapiro { 91964562Sgshapiro $result = "There is already a queued message with id '$self->{id}' in '$destination'"; 92064562Sgshapiro } 92164562Sgshapiro 92264562Sgshapiro if (!$result) 92364562Sgshapiro { 92464562Sgshapiro $result = ::move_file($self->{data_file}->{file_name}, 92564562Sgshapiro $df_dest); 92664562Sgshapiro } 92764562Sgshapiro 92864562Sgshapiro if (!$result) 92964562Sgshapiro { 93064562Sgshapiro $result = ::move_file($self->{control_file}->{file_name}, 93164562Sgshapiro $qf_dest); 93264562Sgshapiro } 93364562Sgshapiro 93464562Sgshapiro $self->unlock(); 93564562Sgshapiro 93664562Sgshapiro return $result; 93764562Sgshapiro} 93864562Sgshapiro 93964562Sgshapirosub parse 94064562Sgshapiro{ 94164562Sgshapiro my $self = shift; 94264562Sgshapiro 94364562Sgshapiro return $self->{control_file}->parse(); 94464562Sgshapiro} 94564562Sgshapiro 94664562Sgshapirosub do_stat 94764562Sgshapiro{ 94864562Sgshapiro my $self = shift; 94964562Sgshapiro 95064562Sgshapiro $self->{control_file}->do_stat(); 95164562Sgshapiro $self->{data_file}->do_stat(); 95264562Sgshapiro} 95364562Sgshapiro 95464562Sgshapirosub setup_vars 95564562Sgshapiro{ 95664562Sgshapiro my $self = shift; 95764562Sgshapiro 95864562Sgshapiro $self->parse(); 95964562Sgshapiro $self->do_stat(); 96064562Sgshapiro} 96164562Sgshapiro 96264562Sgshapirosub delete 96364562Sgshapiro{ 96464562Sgshapiro my $self = shift; 96564562Sgshapiro my $result; 96664562Sgshapiro 96764562Sgshapiro $result = $self->{control_file}->delete(); 96864562Sgshapiro if ($result) 96964562Sgshapiro { 97064562Sgshapiro return $result; 97164562Sgshapiro } 97264562Sgshapiro $result = $self->{data_file}->delete(); 97364562Sgshapiro if ($result) 97464562Sgshapiro { 97564562Sgshapiro return $result; 97664562Sgshapiro } 97764562Sgshapiro 97864562Sgshapiro return undef; 97964562Sgshapiro} 98064562Sgshapiro 98164562Sgshapirosub bounce 98264562Sgshapiro{ 98364562Sgshapiro my $self = shift; 98464562Sgshapiro my $command; 98564562Sgshapiro 98664562Sgshapiro $command = "sendmail -qI$self->{id} -O Timeout.queuereturn=now"; 98764562Sgshapiro# print("$command\n"); 98864562Sgshapiro system($command); 98964562Sgshapiro} 99064562Sgshapiro 99164562Sgshapiro## 99264562Sgshapiro## QUEUE - Represents a queued sendmail queue. 99364562Sgshapiro## 99464562Sgshapiro## This manages all of the messages in a queue. 99564562Sgshapiro## 99664562Sgshapiro 99764562Sgshapiropackage Queue; 99864562Sgshapiro 99964562Sgshapirosub new 100064562Sgshapiro{ 100164562Sgshapiro my $this = shift; 100264562Sgshapiro my $class = ref($this) || $this; 100364562Sgshapiro my $self = {}; 100464562Sgshapiro bless $self, $class; 100564562Sgshapiro $self->initialize(@_); 100664562Sgshapiro return $self; 100764562Sgshapiro} 100864562Sgshapiro 100964562Sgshapirosub initialize 101064562Sgshapiro{ 101164562Sgshapiro my $self = shift; 101264562Sgshapiro 101364562Sgshapiro $self->{queue_dir} = shift; 101464562Sgshapiro $self->{files} = {}; 101564562Sgshapiro} 101664562Sgshapiro 101764562Sgshapiro## 101864562Sgshapiro## READ - Loads the queue with all of the objects that reside in it. 101964562Sgshapiro## 102064562Sgshapiro## This reads the queue's directory and creates QueuedMessage objects 102190792Sgshapiro## for every file in the queue that starts with 'qf' or 'hf' 102290792Sgshapiro## (depending on the -Q option). 102364562Sgshapiro## 102464562Sgshapiro 102564562Sgshapirosub read 102664562Sgshapiro{ 102764562Sgshapiro my $self = shift; 102864562Sgshapiro my @control_files; 102964562Sgshapiro my $queued_message; 103064562Sgshapiro my $file_name; 103164562Sgshapiro my $id; 103264562Sgshapiro my $result; 103364562Sgshapiro my $control_dir; 103464562Sgshapiro my $data_dir; 103564562Sgshapiro 103664562Sgshapiro $control_dir = File::Spec->catfile($self->{queue_dir}, 'qf'); 103764562Sgshapiro 103864562Sgshapiro if (-e $control_dir) 103964562Sgshapiro { 104064562Sgshapiro $data_dir = File::Spec->catfile($self->{queue_dir}, 'df'); 104164562Sgshapiro if (!-e $data_dir) 104264562Sgshapiro { 104364562Sgshapiro $data_dir = $self->{queue_dir}; 104464562Sgshapiro } 104564562Sgshapiro } 104664562Sgshapiro else 104764562Sgshapiro { 104864562Sgshapiro $data_dir = $self->{queue_dir}; 104964562Sgshapiro $control_dir = $self->{queue_dir}; 105064562Sgshapiro } 105164562Sgshapiro 105264562Sgshapiro $result = opendir(QUEUE_DIR, $control_dir); 105364562Sgshapiro if (!$result) 105464562Sgshapiro { 105564562Sgshapiro return "Unable to open directory '$control_dir'"; 105664562Sgshapiro } 105764562Sgshapiro 105890792Sgshapiro @control_files = grep { /^$qprefix.*/ && -f "$control_dir/$_" } readdir(QUEUE_DIR); 105964562Sgshapiro closedir(QUEUE_DIR); 106064562Sgshapiro foreach $file_name (@control_files) 106164562Sgshapiro { 106264562Sgshapiro $id = substr($file_name, 2); 106364562Sgshapiro $queued_message = new QueuedMessage($control_dir, $id, 106464562Sgshapiro $data_dir); 106564562Sgshapiro $self->{files}->{$id} = $queued_message; 106664562Sgshapiro } 106764562Sgshapiro 106864562Sgshapiro return undef; 106964562Sgshapiro} 107064562Sgshapiro 107164562Sgshapiro 107264562Sgshapiro## 107364562Sgshapiro## ADD_QUEUED_MESSAGE - Adds a QueuedMessage to this Queue. 107464562Sgshapiro## 107564562Sgshapiro## Adds the QueuedMessage object to the hash and moves the files 107664562Sgshapiro## associated with the QueuedMessage to this Queue's directory. 107764562Sgshapiro## 107864562Sgshapiro 107964562Sgshapirosub add_queued_message 108064562Sgshapiro{ 108164562Sgshapiro my $self = shift; 108264562Sgshapiro my $queued_message = shift; 108364562Sgshapiro my $result; 108464562Sgshapiro 108564562Sgshapiro $result = $queued_message->move($self->{queue_dir}); 108664562Sgshapiro if ($result) 108764562Sgshapiro { 108864562Sgshapiro return $result; 108964562Sgshapiro } 109064562Sgshapiro 109164562Sgshapiro $self->{files}->{$queued_message->{id}} = $queued_message; 109264562Sgshapiro 109364562Sgshapiro return $result; 109464562Sgshapiro} 109564562Sgshapiro 109664562Sgshapiro## 109764562Sgshapiro## ADD_QUEUE - Adds another Queue's QueuedMessages to this Queue. 109864562Sgshapiro## 109964562Sgshapiro## Adds all of the QueuedMessage objects in the passed in queue 110064562Sgshapiro## to this queue. 110164562Sgshapiro## 110264562Sgshapiro 110364562Sgshapirosub add_queue 110464562Sgshapiro{ 110564562Sgshapiro my $self = shift; 110664562Sgshapiro my $queue = shift; 110764562Sgshapiro my $id; 110864562Sgshapiro my $queued_message; 110964562Sgshapiro my $result; 111064562Sgshapiro 111164562Sgshapiro while (($id, $queued_message) = each %{$queue->{files}}) 111264562Sgshapiro { 111364562Sgshapiro $result = $self->add_queued_message($queued_message); 111464562Sgshapiro if ($result) 111564562Sgshapiro { 111664562Sgshapiro print("$result.\n"); 111764562Sgshapiro } 111864562Sgshapiro } 111964562Sgshapiro} 112064562Sgshapiro 112164562Sgshapiro## 112264562Sgshapiro## ADD - Adds an item to this queue. 112364562Sgshapiro## 112464562Sgshapiro## Adds either a Queue or a QueuedMessage to this Queue. 112564562Sgshapiro## 112664562Sgshapiro 112764562Sgshapirosub add 112864562Sgshapiro{ 112964562Sgshapiro my $self = shift; 113064562Sgshapiro my $source = shift; 113164562Sgshapiro my $type_name; 113264562Sgshapiro my $result; 113364562Sgshapiro 113464562Sgshapiro $type_name = ref($source); 113564562Sgshapiro 113664562Sgshapiro if ($type_name eq "QueuedMessage") 113764562Sgshapiro { 113864562Sgshapiro return $self->add_queued_message($source); 113964562Sgshapiro } 114064562Sgshapiro 114164562Sgshapiro if ($type_name eq "Queue") 114264562Sgshapiro { 114364562Sgshapiro return $self->add_queue($source); 114464562Sgshapiro } 114564562Sgshapiro 114664562Sgshapiro return "Queue does not know how to add a '$type_name'" 114764562Sgshapiro} 114864562Sgshapiro 114964562Sgshapirosub delete 115064562Sgshapiro{ 115164562Sgshapiro my $self = shift; 115264562Sgshapiro my $id; 115364562Sgshapiro my $queued_message; 115464562Sgshapiro 115564562Sgshapiro while (($id, $queued_message) = each %{$self->{files}}) 115664562Sgshapiro { 115764562Sgshapiro $result = $queued_message->delete(); 115864562Sgshapiro if ($result) 115964562Sgshapiro { 116064562Sgshapiro print("$result.\n"); 116164562Sgshapiro } 116264562Sgshapiro } 116364562Sgshapiro} 116464562Sgshapiro 116564562Sgshapirosub bounce 116664562Sgshapiro{ 116764562Sgshapiro my $self = shift; 116864562Sgshapiro my $id; 116964562Sgshapiro my $queued_message; 117064562Sgshapiro 117164562Sgshapiro while (($id, $queued_message) = each %{$self->{files}}) 117264562Sgshapiro { 117364562Sgshapiro $result = $queued_message->bounce(); 117464562Sgshapiro if ($result) 117564562Sgshapiro { 117664562Sgshapiro print("$result.\n"); 117764562Sgshapiro } 117864562Sgshapiro } 117964562Sgshapiro} 118064562Sgshapiro 118164562Sgshapiro## 118264562Sgshapiro## Condition Class 118364562Sgshapiro## 118464562Sgshapiro## This next section is for any class that has an interface called 118564562Sgshapiro## check_move(source, dest). Each class represents some condition to 118664562Sgshapiro## check for to determine whether we should move the file from 118764562Sgshapiro## source to dest. 118864562Sgshapiro## 118964562Sgshapiro 119064562Sgshapiro 119164562Sgshapiro## 119264562Sgshapiro## OlderThan 119364562Sgshapiro## 119464562Sgshapiro## This Condition Class checks the modification time of the 119564562Sgshapiro## source file and returns true if the file's modification time is 1196203004Sgshapiro## older than the number of seconds the class was initialized with. 119764562Sgshapiro## 119864562Sgshapiro 119964562Sgshapiropackage OlderThan; 120064562Sgshapiro 120164562Sgshapirosub new 120264562Sgshapiro{ 120364562Sgshapiro my $this = shift; 120464562Sgshapiro my $class = ref($this) || $this; 120564562Sgshapiro my $self = {}; 120664562Sgshapiro bless $self, $class; 120764562Sgshapiro $self->initialize(@_); 120864562Sgshapiro return $self; 120964562Sgshapiro} 121064562Sgshapiro 121164562Sgshapirosub initialize 121264562Sgshapiro{ 121364562Sgshapiro my $self = shift; 121464562Sgshapiro 121564562Sgshapiro $self->{age_in_seconds} = shift; 121664562Sgshapiro} 121764562Sgshapiro 121864562Sgshapirosub check_move 121964562Sgshapiro{ 122064562Sgshapiro my $self = shift; 122164562Sgshapiro my $source = shift; 122264562Sgshapiro 122364562Sgshapiro if ((time() - $source->last_modified_time()) > $self->{age_in_seconds}) 122464562Sgshapiro { 122564562Sgshapiro return 1; 122664562Sgshapiro } 122764562Sgshapiro 122864562Sgshapiro return 0; 122964562Sgshapiro} 123064562Sgshapiro 123164562Sgshapiro## 123264562Sgshapiro## Compound 123364562Sgshapiro## 123464562Sgshapiro## Takes a list of Move Condition Classes. Check_move returns true 123564562Sgshapiro## if every Condition Class in the list's check_move function returns 123664562Sgshapiro## true. 123764562Sgshapiro## 123864562Sgshapiro 123964562Sgshapiropackage Compound; 124064562Sgshapiro 124164562Sgshapirosub new 124264562Sgshapiro{ 124364562Sgshapiro my $this = shift; 124464562Sgshapiro my $class = ref($this) || $this; 124564562Sgshapiro my $self = {}; 124664562Sgshapiro bless $self, $class; 124764562Sgshapiro $self->initialize(@_); 124864562Sgshapiro return $self; 124964562Sgshapiro} 125064562Sgshapiro 125164562Sgshapirosub initialize 125264562Sgshapiro{ 125364562Sgshapiro my $self = shift; 125464562Sgshapiro 125564562Sgshapiro $self->{condition_list} = []; 125664562Sgshapiro} 125764562Sgshapiro 125864562Sgshapirosub add 125964562Sgshapiro{ 126064562Sgshapiro my $self = shift; 126164562Sgshapiro my $new_condition = shift; 126264562Sgshapiro 126364562Sgshapiro push(@{$self->{condition_list}}, $new_condition); 126464562Sgshapiro} 126564562Sgshapiro 126664562Sgshapirosub check_move 126764562Sgshapiro{ 126864562Sgshapiro my $self = shift; 126964562Sgshapiro my $source = shift; 127064562Sgshapiro my $dest = shift; 127164562Sgshapiro my $condition; 127264562Sgshapiro my $result; 127364562Sgshapiro 127464562Sgshapiro foreach $condition (@{$self->{condition_list}}) 127564562Sgshapiro { 127664562Sgshapiro if (!$condition->check_move($source, $dest)) 127764562Sgshapiro { 127864562Sgshapiro return 0; 127964562Sgshapiro } 128064562Sgshapiro } 128164562Sgshapiro 128264562Sgshapiro return 1; 128364562Sgshapiro} 128464562Sgshapiro 128564562Sgshapiro## 128664562Sgshapiro## Eval 128764562Sgshapiro## 128864562Sgshapiro## Takes a perl expression and evaluates it. The ControlFile object 1289203004Sgshapiro## for the source QueuedMessage is available through the name '$msg'. 129064562Sgshapiro## 129164562Sgshapiro 129264562Sgshapiropackage Eval; 129364562Sgshapiro 129464562Sgshapirosub new 129564562Sgshapiro{ 129664562Sgshapiro my $this = shift; 129764562Sgshapiro my $class = ref($this) || $this; 129864562Sgshapiro my $self = {}; 129964562Sgshapiro bless $self, $class; 130064562Sgshapiro $self->initialize(@_); 130164562Sgshapiro return $self; 130264562Sgshapiro} 130364562Sgshapiro 130464562Sgshapirosub initialize 130564562Sgshapiro{ 130664562Sgshapiro my $self = shift; 130764562Sgshapiro 130864562Sgshapiro $self->{expression} = shift; 130964562Sgshapiro} 131064562Sgshapiro 131164562Sgshapirosub check_move 131264562Sgshapiro{ 131364562Sgshapiro my $self = shift; 131464562Sgshapiro my $source = shift; 131564562Sgshapiro my $dest = shift; 131664562Sgshapiro my $result; 131764562Sgshapiro my %msg; 131864562Sgshapiro 131964562Sgshapiro $source->setup_vars(); 132064562Sgshapiro tie(%msg, 'QueuedMessage', $source); 132164562Sgshapiro $result = eval($self->{expression}); 132264562Sgshapiro 132364562Sgshapiro return $result; 132464562Sgshapiro} 1325