"Fossies" - the Fresh Open Source Software Archive

Member "sendpage-1.001001/lib/Sendpage/Queue.pm" (16 Apr 2009, 10061 Bytes) of package /linux/privat/old/sendpage-1.001001.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "Queue.pm" see the Fossies "Dox" file reference documentation.

    1 package Sendpage::Queue;
    2 
    3 # this tool handles dealing with a single queue directory
    4 # it processes *one* file at a time with a few functions
    5 #
    6 # $Id: Queue.pm 319 2009-04-16 19:19:06Z keescook $
    7 #
    8 # Copyright (C) 2000-2004 Kees Cook
    9 # kees@outflux.net, http://outflux.net/
   10 #
   11 # This program is free software; you can redistribute it and/or
   12 # modify it under the terms of the GNU General Public License
   13 # as published by the Free Software Foundation; either version 2
   14 # of the License, or (at your option) any later version.
   15 #
   16 # This program is distributed in the hope that it will be useful,
   17 # but WITHOUT ANY WARRANTY; without even the implied warranty of
   18 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   19 # GNU General Public License for more details.
   20 #
   21 # You should have received a copy of the GNU General Public License
   22 # along with this program; if not, write to the Free Software
   23 # Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
   24 # <URL:http://www.gnu.org/copyleft/gpl.html>
   25 
   26 use strict;         # Avoid MetaGoof #1
   27 use warnings;           # Avoid MetaGoof #2
   28 
   29 use FileHandle;         # Hmmm, expensive?!?
   30 
   31 =head1 NAME
   32 
   33 Sendpage::Queue - implements a simple directory-based file queue
   34 
   35 =head1 SYNOPSIS
   36 
   37  $queue = Sendpage::Queue->new($dir);
   38 
   39  while ($queue->ready()) {
   40      $filename = $queue->file();
   41      $fh       = $queue->getReadyFile();
   42      if ($can_remove_file) {
   43          $queue->fileToss();
   44      } else {
   45          $queue->fileDone();
   46      }
   47  }
   48 
   49  # open a new queue file
   50  $fh = $queue->getNewFile();
   51  # ... do things to the file handle here
   52  # release the file
   53  $queue->doneNewFile();
   54 
   55 =head1 DESCRIPTION
   56 
   57 This is a module is used internally by L<sendpage> for implementing a
   58 simple queuing system for pages.
   59 
   60 =cut
   61 
   62 # globals
   63 my $DEBUG = 0;
   64 
   65 =head2 Methods
   66 
   67 =over 4
   68 
   69 =item new LIST
   70 
   71 Instantiates a Sendpage::Queue object.
   72 
   73 =cut
   74 
   75 sub new
   76 {
   77     my $proto = shift;
   78     my $class = ref($proto) || $proto;
   79     my $self  =
   80     {
   81      DIR     => shift,      # location of my queue
   82      FILES   => [ ],        # where to store our directory list
   83      OPEN    => undef,      # current open file
   84      COUNTER => 0,      # for the unique filename
   85     };
   86 
   87     unless (-d $self->{DIR}) {
   88     $main::log->do('alert',
   89                "'$self->{DIR}' is not a directory!");
   90     return undef;
   91     }
   92     unless (-w $self->{DIR}) {
   93     $main::log->do('alert',
   94                "Cannot write to '$self->{DIR}' directory!");
   95     return undef;
   96     }
   97     unless (-r $self->{DIR}) {
   98     $main::log->do('alert',
   99                "Cannot read '$self->{DIR}' directory!");
  100     return undef;
  101     }
  102 
  103     return bless $self => $class;
  104 }
  105 
  106 =item file()
  107 
  108 Emit the first file in the queue.
  109 
  110 =cut
  111 
  112 sub file { $_[0]->{FILES}[0] }
  113 
  114 =item ready()
  115 
  116 Check if a Queue is ready.
  117 
  118 =cut
  119 
  120 # is the queue ready to have files taken from it?
  121 sub ready
  122 {
  123     my $self = shift;
  124 
  125     if ($self->{OPEN}) {
  126     $main::log->do('alert',
  127                "File '@{[ $self->file ]}' still open "
  128                . "while checking queue '$self->{DIR}'"
  129                . " -- restarting queue!");
  130     #return -2;
  131     }
  132 
  133     opendir DIRHANDLE, $self->{DIR}
  134     or $main::log->do('alert', "Cannot access '$self->{DIR}': $!");
  135     my @files = readdir DIRHANDLE;
  136     close DIRHANDLE;
  137 
  138     map { warn "$$: in '$self->{DIR}': $_\n" } @files if $DEBUG;
  139 
  140     $self->{FILES} = [ sort( grep /^q/, @files ) ];
  141     @files = @{ $self->{FILES} };
  142 
  143     map { warn "$$: in FILES: $_\n" } @files if $DEBUG;
  144     warn "$$: ready will be: $#files\n"      if $DEBUG;
  145 
  146     return $#files;
  147 }
  148 
  149 =item getReadyFile()
  150 
  151 Get a file handle from the queue.
  152 
  153 =cut
  154 
  155 # get a file handle from the queue
  156 #   handle is locked, and must be release with "fileDone"
  157 sub getReadyFile
  158 {
  159     my $self = shift;
  160     my $fh = new FileHandle;
  161 
  162     if ($self->{OPEN}) {
  163     $main::log->do('alert',
  164                "Cannot read next file from queue '$self->{DIR}'"
  165                . " with open file (@{[ $self->file ]})!");
  166 
  167     return undef;
  168     }
  169     warn "$$: in getReadyFile\n" if $DEBUG;
  170     my @filelist = @{ $self->{FILES} };
  171     my $file     = shift @filelist;
  172     unless (defined $file) {
  173     warn "$$: no more files in queue\n" if $DEBUG;
  174     $main::log->do('debug', "No more files in queue")
  175         if $main::DEBUG;
  176     return undef;
  177     }
  178 
  179     my $err   = "queue '$file' from '$self->{DIR}':";
  180     my $fname = "$self->{DIR}/$file";
  181 
  182     warn "$$: fname is '$fname'\n" if $DEBUG;
  183 
  184     # create new queue files
  185     unless (-f $fname) {
  186     warn "$$: creating '$fname'\n" if $DEBUG;
  187     open $fh, "> $fname"
  188         or $main::log->do('alert', "Cannot write $err $!");
  189     close $fh;
  190     }
  191 
  192     # open queue files read/write
  193     unless (open $fh, "+< $fname") {
  194     warn "$$: cannot read $err $!\n" if $DEBUG;
  195     $main::log->do('alert', "Cannot read $err $!");
  196 
  197     # try the next file
  198     shift @{ $self->{FILES} };
  199     return $self->getReadyFile();
  200     }
  201 
  202     unless ($self->lockFile($fname)) {
  203     warn "$$: cannot lock $err $!\n" if $DEBUG;
  204     $main::log->do('alert', "Cannot lock $err $!");
  205     close $fh;
  206 
  207     # try the next file
  208     shift @{ $self->{FILES} };
  209     return $self->getReadyFile();
  210     }
  211 
  212     unless (-f $fname) {
  213     warn "$$: cannot find '$fname'\n" if $DEBUG;
  214     # someone deleted the file while they had it locked,
  215     close $fh;
  216 
  217     # we should try for the next file in the queue
  218     shift @{ $self->{FILES} };
  219     return $self->getReadyFile();
  220     }
  221 
  222     warn "$$: file handle is '$fh'\n" if $DEBUG;
  223 
  224     return $self->{OPEN} = $fh;
  225 }
  226 
  227 =item fileToss LIST
  228 
  229 Releases locks, closes file, removes file, etc...
  230 
  231 =cut
  232 
  233 # releases locks, closes file, removes file, etc
  234 sub fileToss
  235 {
  236     my ($self, @args) = @_;
  237 
  238     unless ($self->{OPEN}) {
  239     $main::log->do('alert', "Cannot call fileToss without an open file!");
  240     return undef;
  241     }
  242 
  243     # rename before unlock: no one can get it then FIXME: this is not right
  244     my $fname = "$self->{DIR}/@{[ $self->file ]}";
  245 
  246     #   my $newname=$fname;
  247     #   $newname =~ s/^./X/;
  248     #
  249     #   # need the queue dirs here, too
  250     #   $fname=$self->{DIR}."/$fname";
  251     #   $final=$self->{DIR}."/$newname";
  252     #   if (!rename($fname,$final)) {
  253     #       $main::log->do('crit', "Cannot rename '$fname' -> '$final': $!\n");
  254     #   }
  255 
  256     if (unlink($fname) < 1) {
  257     $main::log->do('alert',
  258                "Could not delete file '$fname': $!");
  259     }
  260 
  261     $self->unlockFile($fname);
  262     close $self->{OPEN};
  263     undef $self->{OPEN};
  264 
  265     # drop the filename
  266     shift @{ $self->{FILES} };
  267 
  268     return 1;
  269 }
  270 
  271 =item fileDone()
  272 
  273 Releases locks, closes file, assumes that it should stay...
  274 
  275 =cut
  276 
  277 # releases locks, closes file, assumes that it should stay
  278 sub fileDone
  279 {
  280     my $self = shift;
  281 
  282     unless ($self->{OPEN}) {
  283     $main::log->do('alert',
  284                "Cannot call fileDone without an open file!");
  285     return undef;
  286     }
  287 
  288     my $fname = "$self->{DIR}/@{[ $self->file ]}";
  289 
  290     $self->unlockFile($fname);
  291     close $self->{OPEN};
  292     undef $self->{OPEN};
  293     shift @{ $self->{FILES} };  # drop the leading filename
  294 
  295     return 1;
  296 }
  297 
  298 =item getNewFile()
  299 
  300 Gets a new file handle, must be released with "doneNewFile".
  301 
  302 =cut
  303 
  304 # gets a new file handle, must be released with "doneNewFile"
  305 sub getNewFile
  306 {
  307     my $self = shift;
  308 
  309     if ($self->{OPEN}) {
  310     $main::log->do('alert',
  311                "Cannot create new file for queue '$self->{DIR}'"
  312                . " with open file (@{[ $self->file ]})!");
  313     return undef;
  314     }
  315 
  316     # createUniqueName only works sanely if we don't re-instantiate
  317     # the same PagingQueue multiple times within the same process within
  318     # the same second.  (Since the COUNTER would be reset to zero each
  319     # time)  :(  As a result, we must test for pre-existing queue filenames.
  320     my $name;
  321     do {
  322     $name = $self->createUniqueName();
  323     } while (-f $self->{DIR} . "/q" . $name);
  324     unshift @{ $self->{FILES} }, "Q" . $name;
  325     return $self->getReadyFile();
  326 }
  327 
  328 =item doneNewFile()
  329 
  330 FIXME
  331 
  332 =cut
  333 
  334 sub doneNewFile
  335 {
  336     my $self = shift;
  337 
  338     my ($fname, $final);
  339 
  340     unless (defined $self->{OPEN}) {
  341     $main::log->do('alert',
  342                "Cannot close new file while no file is open!");
  343     return undef;
  344     }
  345 
  346     $fname = $self->file;
  347     if ($fname !~ /^Q/) {
  348     $main::log->do('alert', "Not operating on a new Queue file");
  349     return undef;
  350     }
  351 
  352     my $newname;
  353     ($newname = $fname) =~ s/^Q/q/;
  354 
  355     # need the queue dirs here, too
  356     $fname = "$self->{DIR}/$fname";
  357     $final = "$self->{DIR}/$newname";
  358     unless (rename($fname, $final)) {
  359     $main::log->do('crit', "Cannot rename '$fname' -> '$final': $!\n");
  360     }
  361 
  362     # done with this handle
  363     if ($self->fileDone()) {
  364     return $newname;
  365     }
  366     return undef;
  367 }
  368 
  369 =for developers: add new functions here.
  370 
  371 =back
  372 
  373 =cut
  374 
  375 
  376 #############
  377 # internal functions
  378 #############
  379 
  380 # locks a single file  FIXME
  381 sub lockFile
  382 {
  383     my ($self, $file) = @_;
  384     $main::log->do('debug', "need to be locking '$file'")
  385     if $main::DEBUG;
  386     return 1;
  387 }
  388 
  389 # unlocks a single file   FIXME
  390 sub unlockFile
  391 {
  392     my ($self, $file) = @_;
  393     $main::log->do('debug', "need to be unlocking '$file'")
  394     if $main::DEBUG;
  395     return 1;
  396 }
  397 
  398 # locks the queue run (do we really need this?)
  399 sub lockQueue
  400 {
  401     # Do something to lock the queue
  402 }
  403 
  404 # unlocks the queue directory (may not need this...)
  405 sub unlockQueue
  406 {
  407     # Do something to unlock the queue
  408 }
  409 
  410 # returns a name based on time, process id, hostname, and cycle
  411 # FIXME: USE the hostname
  412 # FIXME: if you re-instantiate the same queue within the same
  413 #        second, within the same process, this will NOT produce
  414 #        a unique name!  Argh.
  415 sub createUniqueName
  416 {
  417     my $self = shift;
  418     $self->{COUNTER} += 1;  # a bit contrived since we're using an
  419                 # lvalued counter
  420 
  421     return sprintf("%010d%05d%03d",
  422            time(), $$, $self->{COUNTER}++);
  423 }
  424 
  425 1;              # This is a module
  426 
  427 __END__
  428 
  429 =head1 AUTHOR
  430 
  431 Kees Cook <kees@outflux.net>
  432 
  433 =head1 BUGS
  434 
  435 Need to write more docs.
  436 
  437 =head1 SEE ALSO
  438 
  439 Man pages: L<perl>, L<sendpage>.
  440 
  441 Module documentation: L<Sendpage::KeesConf>, L<Sendpage::KeesLog>,
  442 L<Sendpage::Modem>, L<Sendpage::PagingCentral>, L<Sendpage::PageQueue>,
  443 L<Sendpage::Page>, L<Sendpage::Recipient>
  444 
  445 =head1 COPYRIGHT
  446 
  447 Copyright 2000 Kees Cook.
  448 
  449 This library is free software; you can redistribute it and/or
  450 modify it under the same terms as Perl itself.
  451 
  452 =cut