Merge from vendor branch GDB:
[dragonfly.git] / contrib / sendmail-8.13.4 / 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.28 2002/06/27 23:06:16 gshapiro 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                 'I' => 'inode_number',
489                 'K' => 'next_delivery_time',
490                 'L' => 'content-length',
491                 'M' => 'message',
492                 'N' => 'num_delivery_attempts',
493                 'P' => 'priority',
494                 'Q' => 'original_recipient',
495                 'R' => 'recipient',
496                 'q' => 'quarantine_reason',
497                 'r' => 'final_recipient',
498                 'S' => 'sender',
499                 'T' => 'creation_time',
500                 'V' => 'version',
501                 'Y' => 'current_delay',
502                 'Z' => 'envid',
503                 '!' => 'deliver_by',
504                 '$' => 'macro'
505         );
506         my $line;
507         my $line_type;
508         my $line_value;
509         my $member_name;
510         my $member;
511         my $last_type;
512
513         open(CONTROL_FILE, "$self->{file_name}");
514         while ($line = <CONTROL_FILE>)
515         {
516                 $line_type = substr($line, 0, 1);
517                 if ($line_type eq "\t" && $last_type eq 'H')
518                 {
519                         $line_type = 'H';
520                         $line_value = $line;
521                 }
522                 else
523                 {
524                         $line_value = substr($line, 1);
525                 }
526                 $member_name = $parse_table{$line_type};
527                 $last_type = $line_type;
528                 if (!$member_name)
529                 {
530                         $member_name = 'unknown';
531                 }
532                 if ($self->can($member_name))
533                 {
534                         $self->$member_name($line_value);
535                 }
536                 $member = $self->{$member_name};
537                 if (!$member)
538                 {
539                         $self->{$member_name} = $line_value;
540                         next;
541                 }
542                 if (ref($member) eq 'ARRAY')
543                 {
544                         push(@{$member}, $line_value);
545                         next;
546                 }
547                 $self->{$member_name} = [$member, $line_value];
548         }
549         close(CONTROL_FILE);
550
551         $self->{parsed} = 1;
552 }
553
554 sub parse_header
555 {
556         my $self = shift;
557         my $line = shift;
558         my $headers = $self->{headers};
559         my $last_header = $self->{last_header};
560         my $header_name;
561         my $header_value;
562         my $first_char;
563
564         $first_char = substr($line, 0, 1);
565         if ($first_char eq "?")
566         {
567                 $line = substr($line, 3);
568         }
569         elsif ($first_char eq "\t")
570         {
571                 if (ref($headers->{$last_header}) eq 'ARRAY')
572                 {
573                         $headers->{$last_header}[-1] = 
574                                 $headers->{$last_header}[-1] . $line;
575                 }
576                 else
577                 {
578                         $headers->{$last_header} = $headers->{$last_header} . 
579                                                    $line;
580                 }
581                 return;
582         }
583         ($header_name, $header_value) = split(/:/, $line, 2);
584         $self->{last_header} = $header_name;
585         if (exists $headers->{$header_name})
586         {
587                 $headers->{$header_name} = [$headers->{$header_name}, 
588                                             $header_value];
589         }
590         else
591         {
592                 $headers->{$header_name} = $header_value;
593         }
594 }
595
596 sub is_locked
597 {
598         my $self = shift;
599
600         return (defined $self->{lock_handle});
601 }
602
603 sub lock
604 {
605         my $self = shift;
606         my $lock_handle;
607         my $result;
608
609         if ($self->is_locked())
610         {
611                 # Already locked
612                 return undef;
613         }
614
615         ($lock_handle, $result) = ::lock_file($self->{file_name});
616         if (!$lock_handle)
617         {
618                 return $result;
619         }
620
621         $self->{lock_handle} = $lock_handle;
622
623         return undef;
624 }
625
626 sub unlock
627 {
628         my $self = shift;
629         my $result;
630
631         if (!$self->is_locked())
632         {
633                 # Not locked
634                 return undef;
635         }
636
637         $result = ::unlock_file($self->{lock_handle});
638
639         $self->{lock_handle} = undef;
640
641         return $result;
642 }
643
644 sub do_stat
645 {
646         my $self = shift;
647         my $result;
648         my @result;
649
650         $result = open(QUEUE_FILE, $self->{file_name});
651         if (!$result)
652         {
653                 return "Unable to open '$self->{file_name}': $!";
654         }
655         @result = stat(QUEUE_FILE);
656         if (!@result)
657         {
658                 return "Unable to stat '$self->{file_name}': $!";
659         }
660         $self->{control_size} = $result[7];
661         $self->{control_last_mod_time} = $result[9];
662 }
663
664 sub DESTROY
665 {
666         my $self = shift;
667
668         $self->unlock();
669 }
670
671 sub delete
672 {
673         my $self = shift;
674         my $result;
675
676         $result = unlink($self->{file_name});
677         if (!$result)
678         {
679                 return "Unable to delete $self->{file_name}: $!";
680         }
681         return undef;
682 }
683
684
685 ##
686 ## DATA_FILE - Represents a sendmail queue data file.
687 ##
688 ##      This object represents represents a sendmail queue data file.
689 ##      It is really just a place-holder.
690 ##
691
692 package DataFile;
693
694 sub new
695 {
696         my $this = shift;
697         my $class = ref($this) || $this;
698         my $self = {};
699         bless $self, $class;
700         $self->initialize(@_);
701         return $self;
702 }
703
704 sub initialize
705 {
706         my $self = shift;
707         my $data_dir = shift;
708         $self->{id} = shift;
709         my $control_file = shift;
710
711         $self->{file_name} = $data_dir . '/df' . $self->{id};
712         return if -e $self->{file_name};
713         $control_file->parse();
714         return if !defined $control_file->{data_file_directory};
715         $data_dir = $queue_root . '/' . $control_file->{data_file_directory};
716         chomp $data_dir;
717         if (-d ($data_dir . '/df'))
718         {
719                 $data_dir .= '/df';
720         }
721         $self->{file_name} = $data_dir . '/df' . $self->{id};
722 }
723
724 sub do_stat
725 {
726         my $self = shift;
727         my $result;
728         my @result;
729
730         $result = open(QUEUE_FILE, $self->{file_name});
731         if (!$result)
732         {
733                 return "Unable to open '$self->{file_name}': $!";
734         }
735         @result = stat(QUEUE_FILE);
736         if (!@result)
737         {
738                 return "Unable to stat '$self->{file_name}': $!";
739         }
740         $self->{body_size} = $result[7];
741         $self->{body_last_mod_time} = $result[9];
742 }
743
744 sub delete
745 {
746         my $self = shift;
747         my $result;
748
749         $result = unlink($self->{file_name});
750         if (!$result)
751         {
752                 return "Unable to delete $self->{file_name}: $!";
753         }
754         return undef;
755 }
756
757
758 ##
759 ## QUEUED_MESSAGE - Represents a queued sendmail message.
760 ##
761 ##      This keeps track of the files that make up a queued sendmail 
762 ##      message.
763 ##      Currently it has 'control_file' and 'data_file' as members.
764 ##
765 ##      You can tie it to a fetch only hash using tie. You need to
766 ##      pass a reference to a QueuedMessage as the third argument
767 ##      to tie.
768 ##
769
770 package QueuedMessage;
771
772 sub new
773 {
774         my $this = shift;
775         my $class = ref($this) || $this;
776         my $self = {};
777         bless $self, $class;
778         $self->initialize(@_);
779         return $self;
780 }
781
782 sub initialize
783 {
784         my $self = shift;
785         my $queue_dir = shift;
786         my $id = shift;
787         my $data_dir = shift;
788
789         $self->{id} = $id;
790         $self->{control_file} = new ControlFile($queue_dir, $id);
791         if (!$data_dir)
792         {
793                 $data_dir = $queue_dir;
794         }
795         $self->{data_file} = new DataFile($data_dir, $id, $self->{control_file});
796 }
797
798 sub last_modified_time
799 {
800         my $self = shift;
801         my @result;
802         @result = stat($self->{data_file}->{file_name});
803         return $result[9];
804 }
805
806 sub TIEHASH
807 {
808         my $this = shift;
809         my $class = ref($this) || $this;
810         my $self = shift;
811         return $self;
812 }
813
814 sub FETCH
815 {
816         my $self = shift;
817         my $key = shift;
818
819         if (exists $self->{control_file}->{$key})
820         {
821                 return $self->{control_file}->{$key};
822         }
823         if (exists $self->{data_file}->{$key})
824         {
825                 return $self->{data_file}->{$key};
826         }
827
828         return undef;
829 }
830
831 sub lock
832 {
833         my $self = shift;
834
835         return $self->{control_file}->lock();
836 }
837
838 sub unlock
839 {
840         my $self = shift;
841
842         return $self->{control_file}->unlock();
843 }
844
845 sub move
846 {
847         my $self = shift;
848         my $destination = shift;
849         my $df_dest;
850         my $qf_dest;
851         my $result;
852
853         $result = $self->lock();
854         if ($result)
855         {
856                 return $result;
857         }
858
859         $qf_dest = File::Spec->catfile($destination, "qf");
860         if (-d $qf_dest)
861         {
862                 $df_dest = File::Spec->catfile($destination, "df");
863                 if (!-d $df_dest)
864                 {
865                         $df_dest = $destination;
866                 }
867         }
868         else
869         {
870                 $qf_dest = $destination;
871                 $df_dest = $destination;
872         }
873
874         if (-e File::Spec->catfile($qf_dest, "$qprefix$self->{id}"))
875         {
876                 $result = "There is already a queued message with id '$self->{id}' in '$destination'";
877         }
878
879         if (!$result)
880         {
881                 $result = ::move_file($self->{data_file}->{file_name}, 
882                                       $df_dest);
883         }
884
885         if (!$result)
886         {
887                 $result = ::move_file($self->{control_file}->{file_name}, 
888                                       $qf_dest);
889         }
890
891         $self->unlock();
892
893         return $result;
894 }
895
896 sub parse
897 {
898         my $self = shift;
899
900         return $self->{control_file}->parse();
901 }
902
903 sub do_stat
904 {
905         my $self = shift;
906
907         $self->{control_file}->do_stat();
908         $self->{data_file}->do_stat();
909 }
910
911 sub setup_vars
912 {
913         my $self = shift;
914
915         $self->parse();
916         $self->do_stat();
917 }
918
919 sub delete
920 {
921         my $self = shift;
922         my $result;
923
924         $result = $self->{control_file}->delete();
925         if ($result)
926         {
927                 return $result;
928         }
929         $result = $self->{data_file}->delete();
930         if ($result)
931         {
932                 return $result;
933         }
934
935         return undef;
936 }
937
938 sub bounce
939 {
940         my $self = shift;
941         my $command;
942
943         $command = "sendmail -qI$self->{id} -O Timeout.queuereturn=now";
944 #       print("$command\n");
945         system($command);
946 }
947
948 ##
949 ## QUEUE - Represents a queued sendmail queue.
950 ##
951 ##      This manages all of the messages in a queue.
952 ##
953
954 package Queue;
955
956 sub new
957 {
958         my $this = shift;
959         my $class = ref($this) || $this;
960         my $self = {};
961         bless $self, $class;
962         $self->initialize(@_);
963         return $self;
964 }
965
966 sub initialize
967 {
968         my $self = shift;
969
970         $self->{queue_dir} = shift;
971         $self->{files} = {};
972 }
973
974 ##
975 ## READ - Loads the queue with all of the objects that reside in it.
976 ##
977 ##      This reads the queue's directory and creates QueuedMessage objects
978 ##      for every file in the queue that starts with 'qf' or 'hf'
979 ##      (depending on the -Q option).
980 ##
981
982 sub read
983 {
984         my $self = shift;
985         my @control_files;
986         my $queued_message;
987         my $file_name;
988         my $id;
989         my $result;
990         my $control_dir;
991         my $data_dir;
992
993         $control_dir = File::Spec->catfile($self->{queue_dir}, 'qf');
994
995         if (-e $control_dir)
996         {
997                 $data_dir = File::Spec->catfile($self->{queue_dir}, 'df');
998                 if (!-e $data_dir)
999                 {
1000                         $data_dir = $self->{queue_dir};
1001                 }
1002         }
1003         else
1004         {
1005                 $data_dir = $self->{queue_dir};
1006                 $control_dir = $self->{queue_dir};
1007         }
1008
1009         $result = opendir(QUEUE_DIR, $control_dir);
1010         if (!$result)
1011         {
1012                 return "Unable to open directory '$control_dir'";
1013         }
1014
1015         @control_files = grep { /^$qprefix.*/ && -f "$control_dir/$_" } readdir(QUEUE_DIR);
1016         closedir(QUEUE_DIR);
1017         foreach $file_name (@control_files)
1018         {
1019                 $id = substr($file_name, 2);
1020                 $queued_message = new QueuedMessage($control_dir, $id, 
1021                                                     $data_dir);
1022                 $self->{files}->{$id} = $queued_message;
1023         }
1024
1025         return undef;
1026 }
1027
1028
1029 ##
1030 ## ADD_QUEUED_MESSAGE - Adds a QueuedMessage to this Queue.
1031 ##
1032 ##      Adds the QueuedMessage object to the hash and moves the files
1033 ##      associated with the QueuedMessage to this Queue's directory.
1034 ##
1035
1036 sub add_queued_message
1037 {
1038         my $self = shift;
1039         my $queued_message = shift;
1040         my $result;
1041
1042         $result = $queued_message->move($self->{queue_dir});
1043         if ($result)
1044         {
1045                 return $result;
1046         }
1047
1048         $self->{files}->{$queued_message->{id}} = $queued_message;
1049
1050         return $result;
1051 }
1052
1053 ##
1054 ## ADD_QUEUE - Adds another Queue's QueuedMessages to this Queue.
1055 ##
1056 ##      Adds all of the QueuedMessage objects in the passed in queue
1057 ##      to this queue.
1058 ##
1059
1060 sub add_queue
1061 {
1062         my $self = shift;
1063         my $queue = shift;
1064         my $id;
1065         my $queued_message;
1066         my $result;
1067
1068         while (($id, $queued_message) = each %{$queue->{files}})
1069         {
1070                 $result = $self->add_queued_message($queued_message);
1071                 if ($result)
1072                 {
1073                         print("$result.\n");
1074                 }
1075         }
1076 }
1077
1078 ##
1079 ## ADD - Adds an item to this queue.
1080 ##
1081 ##      Adds either a Queue or a QueuedMessage to this Queue.
1082 ##
1083
1084 sub add
1085 {
1086         my $self = shift;
1087         my $source = shift;
1088         my $type_name;
1089         my $result;
1090
1091         $type_name = ref($source);
1092
1093         if ($type_name eq "QueuedMessage")
1094         {
1095                 return $self->add_queued_message($source);
1096         }
1097
1098         if ($type_name eq "Queue")
1099         {
1100                 return $self->add_queue($source);
1101         }
1102
1103         return "Queue does not know how to add a '$type_name'"
1104 }
1105
1106 sub delete
1107 {
1108         my $self = shift;
1109         my $id;
1110         my $queued_message;
1111
1112         while (($id, $queued_message) = each %{$self->{files}})
1113         {
1114                 $result = $queued_message->delete();
1115                 if ($result)
1116                 {
1117                         print("$result.\n");
1118                 }
1119         }
1120 }
1121
1122 sub bounce
1123 {
1124         my $self = shift;
1125         my $id;
1126         my $queued_message;
1127
1128         while (($id, $queued_message) = each %{$self->{files}})
1129         {
1130                 $result = $queued_message->bounce();
1131                 if ($result)
1132                 {
1133                         print("$result.\n");
1134                 }
1135         }
1136 }
1137
1138 ##
1139 ## Condition Class
1140 ##
1141 ##      This next section is for any class that has an interface called 
1142 ##      check_move(source, dest). Each class represents some condition to
1143 ##      check for to determine whether we should move the file from 
1144 ##      source to dest.
1145 ##
1146
1147
1148 ##
1149 ## OlderThan
1150 ##
1151 ##      This Condition Class checks the modification time of the
1152 ##      source file and returns true if the file's modification time is
1153 ##      older than the number of seconds the class was initialzed with.
1154 ##
1155
1156 package OlderThan;
1157
1158 sub new
1159 {
1160         my $this = shift;
1161         my $class = ref($this) || $this;
1162         my $self = {};
1163         bless $self, $class;
1164         $self->initialize(@_);
1165         return $self;
1166 }
1167
1168 sub initialize
1169 {
1170         my $self = shift;
1171
1172         $self->{age_in_seconds} = shift;
1173 }
1174
1175 sub check_move
1176 {
1177         my $self = shift;
1178         my $source = shift;
1179
1180         if ((time() - $source->last_modified_time()) > $self->{age_in_seconds})
1181         {
1182                 return 1;
1183         }
1184
1185         return 0;
1186 }
1187
1188 ##
1189 ## Compound
1190 ##
1191 ##      Takes a list of Move Condition Classes. Check_move returns true
1192 ##      if every Condition Class in the list's check_move function returns
1193 ##      true.
1194 ##
1195
1196 package Compound;
1197
1198 sub new
1199 {
1200         my $this = shift;
1201         my $class = ref($this) || $this;
1202         my $self = {};
1203         bless $self, $class;
1204         $self->initialize(@_);
1205         return $self;
1206 }
1207
1208 sub initialize
1209 {
1210         my $self = shift;
1211
1212         $self->{condition_list} = [];
1213 }
1214
1215 sub add
1216 {
1217         my $self = shift;
1218         my $new_condition = shift;
1219
1220         push(@{$self->{condition_list}}, $new_condition);
1221 }
1222
1223 sub check_move
1224 {
1225         my $self = shift;
1226         my $source = shift;
1227         my $dest = shift;
1228         my $condition;
1229         my $result;
1230
1231         foreach $condition (@{$self->{condition_list}})
1232         {
1233                 if (!$condition->check_move($source, $dest))
1234                 {
1235                         return 0;
1236                 }
1237         }
1238         
1239         return 1;
1240 }
1241
1242 ##
1243 ## Eval
1244 ##
1245 ##      Takes a perl expression and evaluates it. The ControlFile object
1246 ##      for the source QueuedMessage is avaliable through the name '$msg'.
1247 ##
1248
1249 package Eval;
1250
1251 sub new
1252 {
1253         my $this = shift;
1254         my $class = ref($this) || $this;
1255         my $self = {};
1256         bless $self, $class;
1257         $self->initialize(@_);
1258         return $self;
1259 }
1260
1261 sub initialize
1262 {
1263         my $self = shift;
1264
1265         $self->{expression} = shift;
1266 }
1267
1268 sub check_move
1269 {
1270         my $self = shift;
1271         my $source = shift;
1272         my $dest = shift;
1273         my $result;
1274         my %msg;
1275
1276         $source->setup_vars();
1277         tie(%msg, 'QueuedMessage', $source);
1278         $result = eval($self->{expression});
1279
1280         return $result;
1281 }