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