Merge from vendor branch LIBSTDC++:
[dragonfly.git] / contrib / sendmail / contrib / qtool.pl
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 ##
8 use strict;
9 use File::Basename;
10 use File::Copy;
11 use File::Spec;
12 use Fcntl qw(:flock :DEFAULT);
13 use 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
60 my %opts;
61 my %sources;
62 my $dst_name;
63 my $destination;
64 my $source_name;
65 my $source;
66 my $result;
67 my $action;
68 my $new_condition;
69 my $qprefix;
70 my $queuegroups = 0;
71 my $conditions = new Compound();
72
73 Getopt::Std::getopts('bC:de:Qs:', \%opts);
74
75 sub 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
87 sub delete_action
88 {
89         my $source = shift;
90
91         return $source->delete();
92 }
93
94 sub bounce_action
95 {
96         my $source = shift;
97
98         return $source->bounce();
99 }
100
101 $action = \&move_action;
102 if (defined $opts{d})
103 {
104         $action = \&delete_action;
105 }
106 elsif (defined $opts{b})
107 {
108         $action = \&bounce_action;
109 }
110
111 if (defined $opts{s})
112 {
113         $new_condition = new OlderThan($opts{s});
114         $conditions->add($new_condition);
115 }
116
117 if (defined $opts{e})
118 {
119         $new_condition = new Eval($opts{e});
120         $conditions->add($new_condition);
121 }
122
123 if (defined $opts{Q})
124 {
125         $qprefix = "hf";
126 }
127 else
128 {
129         $qprefix = "qf";
130 }
131
132 if ($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
146 my $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
199 while (@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
210 if (keys(%sources) == 0)
211 {
212         exit;
213 }
214
215 while (($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
228 sub 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
265 sub 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
356 sub 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
389 sub 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
417 sub 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
441 package ControlFile;
442
443 sub 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
453 sub 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
471 sub 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
555 sub 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
597 sub is_locked
598 {
599         my $self = shift;
600
601         return (defined $self->{lock_handle});
602 }
603
604 sub 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
627 sub 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
645 sub 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
665 sub DESTROY
666 {
667         my $self = shift;
668
669         $self->unlock();
670 }
671
672 sub 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
693 package DataFile;
694
695 sub 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
705 sub 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
725 sub 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
745 sub 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
771 package QueuedMessage;
772
773 sub 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
783 sub 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
799 sub 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
807 sub TIEHASH
808 {
809         my $this = shift;
810         my $class = ref($this) || $this;
811         my $self = shift;
812         return $self;
813 }
814
815 sub 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
832 sub lock
833 {
834         my $self = shift;
835
836         return $self->{control_file}->lock();
837 }
838
839 sub unlock
840 {
841         my $self = shift;
842
843         return $self->{control_file}->unlock();
844 }
845
846 sub 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
897 sub parse
898 {
899         my $self = shift;
900
901         return $self->{control_file}->parse();
902 }
903
904 sub do_stat
905 {
906         my $self = shift;
907
908         $self->{control_file}->do_stat();
909         $self->{data_file}->do_stat();
910 }
911
912 sub setup_vars
913 {
914         my $self = shift;
915
916         $self->parse();
917         $self->do_stat();
918 }
919
920 sub 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
939 sub 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
955 package Queue;
956
957 sub 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
967 sub 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
983 sub 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
1037 sub 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
1061 sub 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
1085 sub 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
1107 sub 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
1123 sub 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
1157 package OlderThan;
1158
1159 sub 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
1169 sub initialize
1170 {
1171         my $self = shift;
1172
1173         $self->{age_in_seconds} = shift;
1174 }
1175
1176 sub 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
1197 package Compound;
1198
1199 sub 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
1209 sub initialize
1210 {
1211         my $self = shift;
1212
1213         $self->{condition_list} = [];
1214 }
1215
1216 sub add
1217 {
1218         my $self = shift;
1219         my $new_condition = shift;
1220
1221         push(@{$self->{condition_list}}, $new_condition);
1222 }
1223
1224 sub 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
1250 package Eval;
1251
1252 sub 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
1262 sub initialize
1263 {
1264         my $self = shift;
1265
1266         $self->{expression} = shift;
1267 }
1268
1269 sub 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 }