[popfile-commit] engine/tests IMAP_test_server.pl,1.4,1.5

[Manni H. <man...@us...>]

Update of /cvsroot/popfile/engine/tests
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv1321/tests

Modified Files:
	IMAP_test_server.pl 
Log Message:
Use latest version of test server.

Index: IMAP_test_server.pl
===================================================================
RCS file: /cvsroot/popfile/engine/tests/IMAP_test_server.pl,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -d -r1.4 -r1.5
*** IMAP_test_server.pl	20 Feb 2006 02:20:57 -0000	1.4
--- IMAP_test_server.pl	1 Dec 2007 11:22:41 -0000	1.5
***************
*** 3,7 ****
  # Tests for IMAP.pm
  #
! # Copyright (c) 2003-2006 John Graham-Cumming
  #
  #   This file is part of POPFile
--- 3,7 ----
  # Tests for IMAP.pm
  #
! # Copyright (c) 2003-2007 John Graham-Cumming
  #
  #   This file is part of POPFile
***************
*** 41,44 ****
--- 41,45 ----
  use IO::Select;
  use File::Copy;
+ use Date::Format;
  use strict;
  use warnings;
***************
*** 49,65 ****
  my $lf = "\012";
  my $eol = "$cr$lf";
! my $debug = 0;
! if ( $ARGV[0] && $ARGV[0] eq 'debug' ) {
!     $debug = 1;
! }
  my $spool = "imap.spool";
  
  my @mailboxes = qw/INBOX spam personal other unclassified/;
  
  
! # This is where we store all the folders' UIDNEXT values 
  my %uidnext;
! foreach ( @mailboxes ) {
!     $uidnext{ $_ } = 1;
  }
  
--- 50,67 ----
  my $lf = "\012";
  my $eol = "$cr$lf";
! my $debug = 1;
  my $spool = "imap.spool";
  
+ # if nothing happens with in $idle_timeout seconds
+ # we call exit.
+ my $idle_timeout = 6;
+ 
  my @mailboxes = qw/INBOX spam personal other unclassified/;
  
  
! # This is where we store all the folders' UIDNEXT values
  my %uidnext;
! foreach my $box ( @mailboxes ) {
!     uid_next( $box, 1 );
  }
  
***************
*** 85,89 ****
  }
  chdir "..";
!     
  
  
--- 87,91 ----
  }
  chdir "..";
! 
  
  
***************
*** 97,107 ****
  die "Socket could not be created. Reason: $!\n" unless ($main_sock);
  
  
  # The endless loop that accepts incoming connections.
  
  while ( 1 ) {
  
      my $new_sock = $main_sock->accept();
- 
      # We set up a pipe that lets the child tell the parent that it
      # no longer needs to wait for new connections.
--- 99,126 ----
  die "Socket could not be created. Reason: $!\n" unless ($main_sock);
  
+ local $SIG{ALRM}
+     = sub {
+             $main_sock->shutdown(2);
+             debug( "Exiting due to idle time-out." );
+             die "IMAP-Test-Server timed out. Did your tests just crash?";
+           };
+ 
  
  # The endless loop that accepts incoming connections.
+ # It's not really endless. There are two ways to exit
+ # that loop:
+ # 1. The regular way: A client tries to login with the user
+ #    name 'shutdown'. In that case, we shut down the socket
+ #    and exit.
+ # 2. If the tests didn't run the way they should and the
+ #    testing parent dies or does something otherwise silly,
+ #    we keep an eye on the clock and exit if nothing happened
+ #    in the last $idle_timeout seconds.
  
  while ( 1 ) {
+     alarm $idle_timeout if $debug;
  
+     debug ( "Waiting for a new client to connect." );
      my $new_sock = $main_sock->accept();
      # We set up a pipe that lets the child tell the parent that it
      # no longer needs to wait for new connections.
***************
*** 109,112 ****
--- 128,132 ----
      pipe my $reader, my $writer;
  
+     debug( "Trying to fork..." );
      my $pid = fork();
      die "Cannot fork: $!" unless defined( $pid );
***************
*** 115,118 ****
--- 135,139 ----
      if ( $pid == 0 ) {
          close $reader;
+         close $main_sock;
          $writer->autoflush( 1 );
  
***************
*** 124,128 ****
          while ( my $buf = <$new_sock> ) {
  
!             debug( "Received a command: $buf" );
              # Look out for the shutdown signal and tell the parent
              # that it's time to go home when we get it. Tell the
--- 145,149 ----
          while ( my $buf = <$new_sock> ) {
  
!             debug( "client said: $buf" );
              # Look out for the shutdown signal and tell the parent
              # that it's time to go home when we get it. Tell the
***************
*** 141,145 ****
  
              if ( $time_out_at == $command_no ) {
!                 sleep 300;
              }
  
--- 162,175 ----
  
              if ( $time_out_at == $command_no ) {
!                 alarm 0 if $debug;
!                 debug( "Going to sleep for $idle_timeout seconds" );
!                 sleep $idle_timeout;
!                 #alarm $idle_timeout if $debug;
!                 # The client is supposed to drop its connection
!                 # at that point. So we are going to do the same thing
!                 # here:
!                 debug( "Child is exiting after time out" );
!                 $new_sock->shutdown( 2 );
!                 exit 0;
              }
  
***************
*** 147,160 ****
              if ( $command_no == $drop_connection_at ) {
                  $new_sock->shutdown( 2 );
              }
- 
              # else we handle the command
              else {
                  handle_command( $new_sock, $buf );
              }
-             
              $command_no++;
          }
! 
          exit 0;
      }
--- 177,189 ----
              if ( $command_no == $drop_connection_at ) {
                  $new_sock->shutdown( 2 );
+                 alarm 0 if $debug;
              }
              # else we handle the command
              else {
                  handle_command( $new_sock, $buf );
              }
              $command_no++;
          }
!         debug( "Child is exiting: EOF from socket" );
          exit 0;
      }
***************
*** 166,169 ****
--- 195,199 ----
  
          my $line = <$reader>;
+         debug ( "child said $line" );
          if ( $line =~ /shutdown/ ) {
              close $reader;
***************
*** 174,178 ****
  
  close $main_sock;
! 
  
  # handle_command
--- 204,208 ----
  
  close $main_sock;
! print "\nThe IMAP_test_server is exiting.\n";
  
  # handle_command
***************
*** 189,193 ****
  
      # LOGIN
- 
          # This section is of special importance because the user name given
          # at login determines which stones we throw at IMAP.pm
--- 219,222 ----
***************
*** 207,214 ****
                  # New messages in one of the incoming mailboxes
                  if ( $user =~ /^new_/ ) {
!                     $user =~ /_(\w+)_/;
                      my $mailbox = $1;
                      while ( $user =~ /_(\d+)/g ) {
!                         file_message ( $mailbox, $1 );
                      }
                  }
--- 236,243 ----
                  # New messages in one of the incoming mailboxes
                  if ( $user =~ /^new_/ ) {
!                     $user =~ /_([a-zA-Z]+)_/;
                      my $mailbox = $1;
                      while ( $user =~ /_(\d+)/g ) {
!                         file_message( $mailbox, $1 );
                      }
                  }
***************
*** 235,239 ****
  
      # LIST
- 
          if ( $command =~ /^LIST "" "\*"/ && $state ne 'Not Authenticated' ) {
              foreach ( @mailboxes ) {
--- 264,267 ----
***************
*** 252,256 ****
  
      # LOGOUT
- 
          if ( $command =~ /^LOGOUT/ ) {
              print $client "* BYE bye$eol";
--- 280,283 ----
***************
*** 262,271 ****
          }
  
- 
      # SELECT
- 
          if ( $command =~ /^SELECT "(.+)"$/ && ( $state eq 'Authenticated' || $state eq 'Selected' ) ) {
              my $mailbox = $1;
  
              if ( exists $uidnext{ $mailbox } ) {
                  $state = 'Selected';
--- 289,297 ----
          }
  
      # SELECT
          if ( $command =~ /^SELECT "(.+)"$/ && ( $state eq 'Authenticated' || $state eq 'Selected' ) ) {
              my $mailbox = $1;
  
+             uid_next ( $mailbox );
              if ( exists $uidnext{ $mailbox } ) {
                  $state = 'Selected';
***************
*** 283,295 ****
  
      # NOOP
!         # (we check for Selected state here because we do not want the
!         # IMAP module to do a NOOP unless we are Selected
! 
!         if ( $command =~ /^NOOP/ && $state eq 'Selected' ) {
              print $client "$tag OK NOOP complete.$eol";
              return;
          }
  
- 
      # EXPUNGE
          if ( $command =~ /^EXPUNGE/ && $state eq 'Selected' ) {
--- 309,317 ----
  
      # NOOP
!         if ( $command =~ /^NOOP/ ) {
              print $client "$tag OK NOOP complete.$eol";
              return;
          }
  
      # EXPUNGE
          if ( $command =~ /^EXPUNGE/ && $state eq 'Selected' ) {
***************
*** 300,311 ****
      # STATUS (we only need to handle STATUS commands asking for the UIDNEXT value because
              # IMAP.pm won't use any other STATUS commands)
!              
!         if ( $command =~ /^STATUS "(.+?)" \(UIDNEXT\)$/ && $state eq "Selected" ) {
  
              my $mailbox = $1;
  
              if ( exists $uidnext{ $mailbox } ) {
                  my $number_of_messages = $uidnext{ $mailbox };
!                 print $client "* STATUS $mailbox (UIDNEXT ", $uidnext{ $mailbox } , ")$eol";
                  print $client "$tag OK STATUS complete.$eol";
              }
--- 322,333 ----
      # STATUS (we only need to handle STATUS commands asking for the UIDNEXT value because
              # IMAP.pm won't use any other STATUS commands)
!         if ( $command =~ /^STATUS "(.+?)" \(UIDNEXT UIDVALIDITY\)$/  ) {
  
              my $mailbox = $1;
+             uid_next( $mailbox );
  
              if ( exists $uidnext{ $mailbox } ) {
                  my $number_of_messages = $uidnext{ $mailbox };
!                 print $client "* STATUS $mailbox (UIDNEXT $uidnext{ $mailbox } UIDVALIDITY $uidvalidity)$eol";
                  print $client "$tag OK STATUS complete.$eol";
              }
***************
*** 322,326 ****
              my $uid = $1;
              my $part = $2;
!             
              my $response;
  
--- 344,348 ----
              my $uid = $1;
              my $part = $2;
! 
              my $response;
  
***************
*** 372,376 ****
                  print $client "$tag NO no such message$eol";
              }
!             
              return;
          }
--- 394,398 ----
                  print $client "$tag NO no such message$eol";
              }
! 
              return;
          }
***************
*** 389,394 ****
          }
  
- 
- 
          # If we get here, we don't know the command and say so
  
--- 411,414 ----
***************
*** 406,416 ****
  
  
! sub select_mailbox
! {
      my ( $client, $mailbox ) = @_;
  
      local $\ = "$eol";
!     
      my @msgs = glob "$spool/$mailbox/*";
  
      print $client "* ", scalar @msgs, " EXISTS";
--- 426,436 ----
  
  
! sub select_mailbox {
      my ( $client, $mailbox ) = @_;
  
      local $\ = "$eol";
! 
      my @msgs = glob "$spool/$mailbox/*";
+     uid_next( $mailbox );
  
      print $client "* ", scalar @msgs, " EXISTS";
***************
*** 423,457 ****
  
  
! sub debug 
! {
      return unless $debug;
      my @messages = @_;
!     open LOG, ">>IMAPdebug.log";
      foreach ( @messages ) {
          s/[\r\n]//g;
!         print LOG "$_\n";
      }
!     close LOG;
  }
!     
! sub file_message
! {
      my ( $folder, $msg ) = @_;
!     
      my $new_uid = $uidnext{ $folder };
!     $uidnext{ $folder }++;
!     
      copy "TestMailParse$msg.msg", "$spool/$folder/$new_uid";
  }
  
  
! sub copy_message
! {
      my ( $uid, $from, $to ) = @_;
!     
      if ( -e "$spool/$from/$uid" ) {
          if ( exists $uidnext{ $to } ) {
              my $new_uid = $uidnext{ $to };
!             $uidnext{ $to }++;
              copy "$spool/$from/$uid", "$spool/$to/$new_uid";
              return 'OK Completed';
--- 443,477 ----
  
  
! sub debug {
      return unless $debug;
      my @messages = @_;
!     open my $LOG, '>>', 'IMAPdebug.log';
      foreach ( @messages ) {
          s/[\r\n]//g;
!         my $time = time2str( "%H:%M:%S", time );
!         print $LOG "$time: $_\n";
      }
!     close $LOG;
  }
! 
! sub file_message {
      my ( $folder, $msg ) = @_;
! 
!     uid_next( $folder );
      my $new_uid = $uidnext{ $folder };
!     uid_next( $folder, $uidnext{ $folder }+1 );
!     debug( "Trying to copy TestMailParse$msg.msg to $spool/$folder/$new_uid" );
      copy "TestMailParse$msg.msg", "$spool/$folder/$new_uid";
  }
  
  
! sub copy_message {
      my ( $uid, $from, $to ) = @_;
! 
      if ( -e "$spool/$from/$uid" ) {
+         uid_next( $to );
          if ( exists $uidnext{ $to } ) {
              my $new_uid = $uidnext{ $to };
!             uid_next( $to, $uidnext{ $to }+1 );
              copy "$spool/$from/$uid", "$spool/$to/$new_uid";
              return 'OK Completed';
***************
*** 459,472 ****
              return 'NO [TRYCREATE] Mailbox does not exist';
          }
!     } else {
!         return 'NO Message does not exist';
      }
  }
!     
!     
! sub delete_message
! {
      my ( $folder, $uid ) = @_;
!     
      if ( -e "$spool/$folder/$uid" ) {
          unlink "$spool/$folder/$uid";
--- 479,492 ----
              return 'NO [TRYCREATE] Mailbox does not exist';
          }
!     }
!     else {
!         return "NO Message '$spool/$from/$uid' does not exist";
      }
  }
! 
! 
! sub delete_message {
      my ( $folder, $uid ) = @_;
! 
      if ( -e "$spool/$folder/$uid" ) {
          unlink "$spool/$folder/$uid";
***************
*** 479,489 ****
  
  
! 
! sub search_messages_ge
! {
      my ( $folder, $uid ) = @_;
!     
      chdir "$spool/$folder/";
!     
      my @list;
      foreach ( glob "*" ) {
--- 499,507 ----
  
  
! sub search_messages_ge {
      my ( $folder, $uid ) = @_;
! 
      chdir "$spool/$folder/";
! 
      my @list;
      foreach ( glob "*" ) {
***************
*** 494,507 ****
          $flat .= " $_";
      }
!     
      chdir "../..";
!     
      return $flat;
  }
  
! sub get_header_fields
! {
      my ( $folder, $uid ) = @_;
!     
      if ( -e "$spool/$folder/$uid" ) {
          open MSG, "$spool/$folder/$uid";
--- 512,524 ----
          $flat .= " $_";
      }
! 
      chdir "../..";
! 
      return $flat;
  }
  
! sub get_header_fields {
      my ( $folder, $uid ) = @_;
! 
      if ( -e "$spool/$folder/$uid" ) {
          open MSG, "$spool/$folder/$uid";
***************
*** 523,538 ****
          close MSG;
          my @headers = qw/message-id date subject received/;
!         
          my $response = '';
!         
          foreach ( @headers ) {
              if ( exists $header{ $_ } ) {
                  $response .= "\u$_: ${$header{ $_ }}[0]$eol";
!             } 
          }
!         
          return $response;
      }
      else {
          return;
      }
--- 540,560 ----
          close MSG;
          my @headers = qw/message-id date subject received/;
! 
          my $response = '';
! 
          foreach ( @headers ) {
              if ( exists $header{ $_ } ) {
                  $response .= "\u$_: ${$header{ $_ }}[0]$eol";
!             }
          }
! 
!         unless ( $response ) {
!             warn "Server couldn't find any header fields in message '$spool/$folder/$uid'\n";
!         }
! 
          return $response;
      }
      else {
+         warn "Server could not find file '$spool/$folder/$uid'\n";
          return;
      }
***************
*** 540,548 ****
  
  
! 
! sub get_message
! {
      my ( $folder, $uid ) = @_;
!     
      if ( -e "$spool/$folder/$uid" ) {
          open MSG, "$spool/$folder/$uid";
--- 562,568 ----
  
  
! sub get_message {
      my ( $folder, $uid ) = @_;
! 
      if ( -e "$spool/$folder/$uid" ) {
          open MSG, "$spool/$folder/$uid";
***************
*** 562,569 ****
  
  
! sub get_message_header
! {
      my ( $folder, $uid ) = @_;
!     
      if ( -e "$spool/$folder/$uid" ) {
          my $response = '';
--- 582,588 ----
  
  
! sub get_message_header {
      my ( $folder, $uid ) = @_;
! 
      if ( -e "$spool/$folder/$uid" ) {
          my $response = '';
***************
*** 575,579 ****
          }
          close MSG;
!         
          return "$response$eol";
      }
--- 594,598 ----
          }
          close MSG;
! 
          return "$response$eol";
      }
***************
*** 583,590 ****
  }
  
! sub get_message_text
! {
      my ( $folder, $uid ) = @_;
!     
      if ( -e "$spool/$folder/$uid" ) {
          my $response = '';
--- 602,608 ----
  }
  
! sub get_message_text {
      my ( $folder, $uid ) = @_;
! 
      if ( -e "$spool/$folder/$uid" ) {
          my $response = '';
***************
*** 604,605 ****
--- 622,655 ----
  }
  
+ 
+ sub uid_next {
+     my $folder  = shift;
+     my $uidnext = shift;
+ 
+     if ( open my $UIDS, '<', 'imap.uids' ) {
+         while ( <$UIDS> ) {
+             /(.+):(.+)[\r\n]/;
+             $uidnext{ $1 } = $2;
+         }
+     }
+ #    else {
+ #        die "IMAP-test-server has a problem: cannot open file 'imap.uids'";
+ #    }
+ 
+     if ( defined $uidnext ) {
+         $uidnext{ $folder } = $uidnext;
+         if ( open my $UIDS, '>', 'imap.uids' ) {
+             foreach ( keys %uidnext ) {
+                 print $UIDS "$_:$uidnext{ $_ }\n";
+             }
+         }
+         else {
+             die "IMAP-test-server has a problem: cannot open file 'imap.uids'";
+         }
+     }
+ 
+     return $uidnext{ $folder };
+ }
+ 
+ 
+