[popfile-commit] engine/tests IMAP_test_server.pl, 1.2.4.1, 1.2.4.2 TestIMAP.tst, 1.3.4.1, 1.3.4.2

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

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

Modified Files:
      Tag: b0_22_2
	IMAP_test_server.pl TestIMAP.tst 
Log Message:
Major changes:

* refactored the code and created a new module that contains all the IMAP-client code. This makes the IMAP stuff much simpler to maintain.
* added a method that will use only one connection to keep all our folders under control. This new mode is now the default.
* did much work on the IMAP tests. coverage for the client module: 86%, for the IMAP module itself: 58%. 

TODO: 
* port this to cvs HEAD
* document installation of the new module.
* add yet more tests.
* test in the wild

Index: TestIMAP.tst
===================================================================
RCS file: /cvsroot/popfile/engine/tests/TestIMAP.tst,v
retrieving revision 1.3.4.1
retrieving revision 1.3.4.2
diff -C2 -d -r1.3.4.1 -r1.3.4.2
*** TestIMAP.tst	6 Feb 2006 15:19:10 -0000	1.3.4.1
--- TestIMAP.tst	11 Nov 2007 16:42:54 -0000	1.3.4.2
***************
*** 23,27 ****
  #
  # ---------------------------------------------------------------------------------------------
! 
  
  use POPFile::Configuration;
--- 23,39 ----
  #
  # ---------------------------------------------------------------------------------------------
! # TODO:
! # IMAP.pm:
! # * changed uidvalidity while connecting
! # * fail while statusing
! # * duplicate hash value => duplicate message in inbox
! # * fail while fetching a part
! # * fail while fetching_header_fields
! # * configure and validate item
! #
! # Client.pm
! # * ssl connection (difficult)
! # * fail while saying something
! # * say no to copy msg
  
  use POPFile::Configuration;
***************
*** 32,49 ****
  use Classifier::Bayes;
  use Classifier::WordMangle;
  
  $SIG{CHLD} = 'IGNORE';
  
- rmtree( 'messages' );
- rmtree( 'corpus' );
- test_assert( rec_cp( 'corpus.base', 'corpus' ) );
- test_assert( rmtree( 'corpus/CVS' ) > 0 );
- 
- unlink 'popfile.db';
- unlink 'stopwords';
- test_assert( copy ( 'stopwords.base', 'stopwords' ) );
- 
- mkdir 'messages';
- 
  # This test will fork itself. The child will run
  # the test server, the parent will run the tests.
--- 44,51 ----
  use Classifier::Bayes;
  use Classifier::WordMangle;
+ use File::Copy;
  
  $SIG{CHLD} = 'IGNORE';
  
  # This test will fork itself. The child will run
  # the test server, the parent will run the tests.
***************
*** 60,124 ****
  else {
      # First, start POPFile.
  
-     my $c = new POPFile::Configuration;
-     my $mq = new POPFile::MQ;
-     my $l = new POPFile::Logger;
-     my $b = new Classifier::Bayes;
-     my $w = new Classifier::WordMangle;
-     my $h = new POPFile::History;
      my $im = new Services::IMAP;
  
!     $c->configuration( $c );
!     $c->mq( $mq );
!     $c->logger( $l );
  
!     $c->initialize();
  
-     $l->configuration( $c );
-     $l->mq( $mq );
-     $l->logger( $l );
  
!     $l->initialize();
  
!     $w->configuration( $c );
!     $w->mq( $mq );
!     $w->logger( $l );
  
!     $w->start();
  
!     $mq->configuration( $c );
!     $mq->mq( $mq );
!     $mq->logger( $l );
  
!     $b->configuration( $c );
!     $b->mq( $mq );
!     $b->logger( $l );
  
!     $h->configuration( $c );
!     $h->mq( $mq );
!     $h->logger( $l );
  
!     $b->history( $h );
!     $h->classifier( $b );
  
!     $h->initialize();
  
!     $b->module_config_( 'html', 'language', 'English' );
!     $b->module_config_( 'html', 'port', '8080' );
!     
!     $b->{parser__}->mangle( $w );
!     $b->initialize();
  
!     test_assert( $b->start() );
!     test_assert( $h->start() );
  
!     my $session = $b->get_session_key( 'admin', '' );
  
!     #$l->config_( 'level', 2 );
!     $l->service();
  
!     # Configure the IMAP module so it will
!     # talk to the server.
  
      $im->configuration( $c );
      $im->mq( $mq );
--- 62,355 ----
  else {
      # First, start POPFile.
+     my ( $c, $mq, $l, $b, $w, $h ) = start_popfile();
  
      my $im = new Services::IMAP;
+     my $session = $b->get_session_key( 'admin', '' );
  
!     # Configure the IMAP module so it will
!     # talk to the server.
!     configure_imap_module( $im, $c, $mq, $l, $b, $h );
!     test_imap_module( $im, $c, $mq, $l, $b, $h );
!     test_imap_client( $im );
  
!     $mq->stop();
!     $h->stop();
!     $im->stop();
!     $b->stop();
!     rmtree( 'imap.spool' );
! }
  
  
! #################################################################################
! # Tests for Services::IMAP
! # Test classification, reclassification, UI stuff and error handling
! ##
  
! sub test_imap_module {
!     my ( $im, $c, $mq, $l, $b, $h ) = @_;
  
!     my $session = $b->get_session_key( 'admin', '' );
!     test_assert( $im->start() );
  
!     # Login. The server doesn't have any messages for us yet
!     $im->log_( 0, "---- testing login to empty server (uidnext and uidvalidity)" );
!     $im->config_( 'login', 'someone' );
!     $im->service();
  
!     foreach my $folder (qw/ INBOX personal spam other / ) {
!         my $client = $im->{folders__}{$folder}{imap};
!         test_assert( $client );
  
!         # Did we get the UIDVALIDITY values correctly?
!         test_assert_equal( $client->uid_validity( $folder ), 1 );
  
!         # Did we note the correct UIDNEXT values?
!         test_assert_equal( $client->uid_next( $folder ), 1 );
!     }
  
!     # We change the uidvalidity and see whether the module detects
!     # the difference between the (manipulated) stored value and
!     # the value from the server.
!     my $client = $im->{folders__}{'spam'}{imap};
!     $client->uid_validity( 'spam', 50 );
!     $im->{last_update__} = 0;
!     $im->service();
!     test_assert_equal( $client->uid_validity( 'spam' ), 1 );
  
!     $im->disconnect_folders__();
  
!     # Let the INBOX have four new messages, make sure they are
!     # classified correctly and moved to the according folders.
!     $im->log_( 0, "---- testing classify with 6 new messages" );
!     $im->config_( 'login', 'new_INBOX_007_003_004_005_013_021' );
!     $b->create_magnet( $session, 'other', 'from', 'cxc...@ya...' );
!     $im->{last_update__} = 0;
!     $im->service();
!     $mq->service();
!     $h->service();
  
!     # The message must have ended up as spam and must have been
!     # moved to the spam folder, except for the magneted msg.
  
!     test_assert( -e 'imap.spool/spam/1' );
!     test_assert( -e 'imap.spool/spam/2' );
!     test_assert( -e 'imap.spool/spam/3' );
!     test_assert( -e 'imap.spool/spam/4' );
!     test_assert( -e 'imap.spool/spam/5' );
!     test_assert( -e 'imap.spool/other/1' );
  
!     # move msgs 1, 2, and 3 to folder presonal
!     $client = $im->{folders__}{'spam'}{imap};
!     test_assert( $client );
!     test_assert_equal( $client->select( 'spam' ), 1 );
!     test_assert_equal( $client->move_message( 1, 'personal' ), 1 );
!     test_assert_equal( $client->move_message( 2, 'personal' ), 1 );
!     test_assert_equal( $client->move_message( 3, 'personal' ), 1 );
! 
!     # move msgs 4 and 5 to folder other
!     test_assert_equal( $client->move_message( 4, 'other' ), 1 );
!     test_assert_equal( $client->move_message( 5, 'other' ), 1 );
! 
!     # let the IMAP module have a look
!     $im->log_( 0, "---- Testing reclassification" );
!     $im->{last_update__} = 0;
!     $im->service();
!     $mq->service();
!     $h->service();
  
+     # check classification stored in history
+     test_assert_equal( ($h->get_slot_fields( 1 ))[8], 'personal' );
+     test_assert_equal( ($h->get_slot_fields( 2 ))[8], 'personal' );
+     test_assert_equal( ($h->get_slot_fields( 3 ))[8], 'personal' );
+     test_assert_equal( ($h->get_slot_fields( 4 ))[8], 'other' );
+     test_assert_equal( ($h->get_slot_fields( 5 ))[8], 'other' );
+ 
+     # check that history knows that the msgs were reclassfified
+     test_assert_equal( ($h->get_slot_fields( 1 ))[9], 4 );
+     test_assert_equal( ($h->get_slot_fields( 2 ))[9], 4 );
+     test_assert_equal( ($h->get_slot_fields( 3 ))[9], 4 );
+     test_assert_equal( ($h->get_slot_fields( 4 ))[9], 4 );
+     test_assert_equal( ($h->get_slot_fields( 5 ))[9], 4 );
+ 
+     # history should also know about the used manget
+     test_assert_equal( ($h->get_slot_fields( 6 ))[11], 'cxc...@ya...' );
+ 
+     # get the msgs hashes and ask the imap module whether those messages
+     # can be reclassified. It should say 'no!'
+     foreach ( 1 .. 5 ) {
+         my $hash = ($h->get_slot_fields( $_ ))[6];
+         test_assert_equal( $im->can_reclassify__( $hash, 'spam' ), undef );
+         test_assert_equal( $im->can_classify__( $hash ), undef );   #QUATSCH
+     }
+ 
+     # check that a fresh classification confirms the reclassification
+     test_assert_equal( $b->classify( $session, 'TestMailParse007.msg' ), 'personal' );
+ 
+     $im->disconnect_folders__();
+ 
+     # Check what happens when we time out
+     $im->log_( 0, "---- Testing time-out behaviour for the module." );
+     $im->config_( 'login', 'timeOut1' );
+     $im->{last_update__} = 0;
+     $im->service();
+     $im->disconnect_folders__();
+ 
+     # Make the server drop the connection and make sure we don't crash
+     $im->log_( 0, "---- Testing dropped-connection behaviour for the module." );
+     $im->config_( 'login', 'dropConnection3' );
+     $im->{last_update__} = 0;
+     $im->service();
+ 
+     $im->log_( 0, "---- Testing train_on_archive." );
+     $im->config_( login => 'new_INBOX_007_003_004_005_013_021' );
+     $im->{last_update__} = 0;
+     $client = $im->new_imap_client();
+     $client->select( 'INBOX' );
+     $client->move_message( 7, 'personal' );
+     $client->move_message( 8, 'other' );
+     $client->move_message( 9, 'spam' );
+     $client->move_message( 10, 'personal' );
+     $client->move_message( 11, 'other' );
+     $client->move_message( 12, 'spam' );
+ 
+     $im->config_( 'training_mode', 1 );
+     $im->config_( login => 'someone' );
+     $im->service();
+     test_assert_equal( $im->config_( 'training_mode' ), 0 );
+ 
+     # Test the multiple-connection approach
+     $im->log_( 0, "---- Testing multiple connections" );
+     $im->config_( use_multiple_connections => 1 );
+     $im->config_( login => 'someone' );
+     $im->{last_update__} = 0;
+     $im->service();
+     $im->config_( use_multiple_connections => 0 );
+     # TODO: login and place some msgs in the INBOX.
+     #       check classifications.
+ }
+ 
+ 
+ #################################################################################
+ # Tests for Services::IMAP::Client
+ # Test the code that actually talks to the IMAP
+ # server
+ ##
+ 
+ sub test_imap_client {
+     my $im = shift;
+ 
+     $im->log_( 0, "---- Testing various client methods" );
+     $im->config_( 'login', 'someone' );
+     my $client = $im->new_imap_client();
+ 
+     test_assert( $client, "Have we got a valid imap client?" );
+     test_assert( $client->connected() );
+     my @mailboxes = $client->get_mailbox_list();
+     test_assert_equal( scalar @mailboxes, 5 );
+ 
+     test_assert_equal( 1, $client->noop() );
+     my $info = $client->status( 'INBOX' );
+     test_assert_equal( $info->{UIDNEXT}, 13 );
+     test_assert_equal( $info->{UIDVALIDITY}, 1 );
+     test_assert_equal( $client->select( 'INBOX' ), 1 );
+ 
+     test_assert_equal( $client->uid_next( 'INBOX' ), 7  );
+     test_assert_equal( $client->uid_validity( 'INBOX' ), 1 );
+ 
+     $client->uid_next( 'INBOX', 100 );
+     test_assert_equal( $client->uid_next( 'INBOX' ), 100 );
+ 
+     $client->uid_validity( 'INBOX', 99 );
+     test_assert_equal( $client->uid_validity( 'INBOX' ), 99 );
+ 
+     $client->uid_validity( 'INBOX', 1 );
+     test_assert_equal( $client->uid_validity( 'INBOX' ), 1 );
+ 
+     test_assert_equal( 1, $client->expunge() );
+ 
+     $client->say( 'unknown command' );
+     test_assert_equal( $client->get_response(), -1 );
+ 
+     test_assert_equal( $client->select( 'personal' ), 1 );
+     $client->uid_next( 'personal', 0 );
+     my @msgs = $client->get_new_message_list();
+     test_assert_equal( scalar @msgs, 5 );
+ 
+     $client->move_message( 1, 'spam' );
+     $client->uid_next( 'spam', 0 );
+     $client->select( 'spam' );
+     @msgs = $client->get_new_message_list();
+     test_assert_equal( scalar @msgs, 3 );
+ 
+     test_assert( $client->logout());
+ 
+     $im->log_( 0, "---- testing client methods with 3 new messages." );
+     $im->config_( 'login', 'new_INBOX_003_002_001' );
+     $client = $im->new_imap_client();
+     $client->uid_next( 'INBOX', 0 );
+     @msgs = $client->get_new_message_list_unselected( 'INBOX' );
+     test_assert_equal( scalar @msgs, 3 );
+ 
+     # Now get the messages and compare them to the originals
+     foreach my $msg_number ( qw/ 003 002 001 / ) {
+         my $uid = shift @msgs;
+         my ( $ok, @msg_lines ) = $client->fetch_message_part( $uid, '' );
+         test_assert_equal( $ok, 1 );
+         my $filename = "TestMailParse$msg_number.msg";
+         if ( open my $ORG, '<', $filename ) {
+             my @org_lines = ();
+             while ( <$ORG> ) {
+                 push @org_lines, $_;
+             }
+             close $ORG;
+             foreach my $org_line ( @org_lines ) {
+                 my $msg_line = shift @msg_lines;
+                 $org_line =~ s/[\r\n]//g;
+                 $msg_line =~ s/[\r\n]//g;
+                 test_assert_equal( $msg_line, $org_line );
+             }
+             $uid++;
+         }
+         else {
+             die "Could not open message $filename ($!)";
+         }
+     }
+ 
+     $im->log_( 0, "---- Testing failing login behaviour for client" );
+     $im->config_( 'login', 'fail' );
+     $im->new_imap_client();
+     test_assert_equal( $im->{imap_error}, 'NO_LOGIN' );
+ 
+     $im->log_( 0, "---- testing time-out behaviour in client" );
+     $im->config_( 'login', 'timeOut1' );
+     $client = $im->new_imap_client();
+     eval {
+         $client->get_mailbox_list();
+     };
+     test_assert( $@ );
+     test_assert_regexp( $@, 'POPFILE-IMAP-EXCEPTION: ' );
+     # sleep 3;
+ 
+     $im->log_( 0, "---- testing something with the client here." );
+     $im->config_( 'login', 'new_INBOX_003_002_001' );
+ 
+     $im->log_( 0, "shutting down the test server by logging in as user 'shutdown'." );
+     # close the server process by logging in as user "shutdown"
+     $im->config_( 'login', 'shutdown' );
+     eval {
+         $im->new_imap_client();
+     };
+     test_assert( $im->{imap_error} );
+     test_assert_equal( $im->{imap_error}, 'NO_LOGIN' );
+ }
+ 
+ 
+ #################################################################################
+ # configure_imap_module
+ # Tweak our configuration settings to prepare the test environment
+ ##
+ 
+ sub configure_imap_module {
+     my ( $im, $c, $mq, $l, $b, $h ) = @_;
      $im->configuration( $c );
      $im->mq( $mq );
***************
*** 136,139 ****
--- 367,373 ----
      $im->config_( 'watched_folders', '' );
  
+     $im->global_config_( 'message_cutoff', 100000 );
+     $im->global_config_( 'timeout', 4 );
+ 
      $im->{last_update__} = 0;
      $im->watched_folders__( 'INBOX' );
***************
*** 142,227 ****
      $im->folder_for_bucket__( 'other', 'other' );
      $im->folder_for_bucket__( 'unclassified', 'unclassified' );
  
-     test_assert( $im->start() );
  
!     $im->config_( 'login', 'someone' );
!     $im->service();
  
!     # Did we get the UIDVALIDITY values correctly?
!     test_assert_equal( $im->uid_validity__( 'INBOX' ), 1 );
!     test_assert_equal( $im->uid_validity__( 'personal' ), 1 );
!     test_assert_equal( $im->uid_validity__( 'spam' ), 1 );
!     test_assert_equal( $im->uid_validity__( 'other' ), 1 );
  
!     # Did we note the correct UIDNEXT values?
!     test_assert_equal( $im->uid_next__( 'INBOX' ), 1 );
!     test_assert_equal( $im->uid_next__( 'personal' ), 1 );
!     test_assert_equal( $im->uid_next__( 'spam' ), 1 );
!     test_assert_equal( $im->uid_next__( 'other' ), 1 );
  
!     $im->disconnect_folders__();
  
!     # Let the INBOX have one new message, make sure it is classified correctly
!     # and moved to the according folder.
!     
!     $im->config_( 'login', 'new_INBOX_003' );
!     $im->{last_update__} = 0;
!     $im->service();
!     $mq->service();
!     $h->service();
!     
!     # The message must have ended up as spam and must have been
!     # moved to the spam folder
!     
!     test_assert( -e 'imap.spool/spam/1' );
!     
!     # This is a good opportunity to test reclassify-on-move:
!     # we move the message from the spam folder to the
!     # personal folder. The IMAP module should see this and
!     # reclassify the message to that bucket. We test whether 
!     # history returns the changed classification and if
!     # bayes comes up with the same classification
!     
!     # move to folder presonal
!     copy 'imap.spool/spam/1', 'imap.spool/personal/1';
!     unlink 'imap.spool/spam/1';
!     
!     # let the IMAP module have a look
!     $im->{last_update__} = 0;
!     $im->service();
!     $mq->service();
!     $h->service();
!     
!     # check classification stored in history
!     test_assert_equal( ($h->get_slot_fields( 1 ))[8], 'personal' );
!     
!     # check that a fresh classification confirms the reclassification
!     test_assert_equal( $b->classify( $session, 'TestMailParse003.msg' ), 'personal' );
!     
!     $im->disconnect_folders__();
!     
!     # test magnet match
!     
!     
!     # Make the server drop the connection and make sure we don't crash
!     
!     $im->config_( 'login', 'dropConnection3' );
!     $im->service();
  
!     # close the server process by logging in as user "shutdown"
!     $im->config_( 'login', 'shutdown' );
!     $im->{last_update__} = 0;
!     $im->service();
  
!     foreach ( $b->get_buckets( $session ) ) { print "$_\n"; }
  
!     $mq->stop();
!     $h->stop();
!     $im->stop();
!     $b->stop();
!     
!     rmtree( 'imap.spool' );
  }
  
- 1;
  
--- 376,436 ----
      $im->folder_for_bucket__( 'other', 'other' );
      $im->folder_for_bucket__( 'unclassified', 'unclassified' );
+ }
  
  
! #################################################################################
! # start_popfile
! # Bring up the POPFile engine and prepare the test environment
! ##
  
! sub start_popfile {
  
!     rmtree( 'messages' );
!     rmtree( 'corpus' );
!     test_assert( rec_cp( 'corpus.base', 'corpus' ) );
!     test_assert( rmtree( 'corpus/CVS' ) > 0 );
  
!     unlink 'popfile.db';
!     unlink 'stopwords';
!     test_assert( copy ( 'stopwords.base', 'stopwords' ) );
  
!     mkdir 'messages';
  
!     my $c = new POPFile::Configuration;
!     my $mq = new POPFile::MQ;
!     my $l = new POPFile::Logger;
!     my $b = new Classifier::Bayes;
!     my $w = new Classifier::WordMangle;
!     my $h = new POPFile::History;
  
!     foreach ( $c, $l, $w, $mq, $h, $b ) {
!         $_->configuration( $c );
!         $_->mq( $mq );
!         $_->logger( $l ) unless $_ == $l;
!     }
  
!     $b->history( $h );
!     $h->classifier( $b );
!     $h->initialize();
! 
!     $b->module_config_( 'html', 'language', 'English' );
!     $b->module_config_( 'html', 'port', '8080' );
! 
!     $b->{parser__}->mangle( $w );
!     $b->initialize();
! 
!     test_assert( $b->start() );
!     test_assert( $h->start() );
! 
!     $l->initialize();
!     $l->config_( 'level', 1 );
! 
!     $l->config_( logdir => '/tmp/' );
!     $l->global_config_( msgdir => 'msgs' );
!     $l->service();
! 
!     return ( $c, $mq, $l, $b, $w, $h );
  }
  
  
+ 1;

Index: IMAP_test_server.pl
===================================================================
RCS file: /cvsroot/popfile/engine/tests/IMAP_test_server.pl,v
retrieving revision 1.2.4.1
retrieving revision 1.2.4.2
diff -C2 -d -r1.2.4.1 -r1.2.4.2
*** IMAP_test_server.pl	6 Feb 2006 15:19:10 -0000	1.2.4.1
--- IMAP_test_server.pl	11 Nov 2007 16:42:54 -0000	1.2.4.2
***************
*** 41,44 ****
--- 41,45 ----
  use IO::Select;
  use File::Copy;
+ use Date::Format;
  use strict;
  use warnings;
***************
*** 49,62 ****
  my $lf = "\012";
  my $eol = "$cr$lf";
! my $debug = 0;
  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 );
  }
  
***************
*** 82,86 ****
  }
  chdir "..";
!     
  
  
--- 87,91 ----
  }
  chdir "..";
! 
  
  
***************
*** 94,104 ****
  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.
***************
*** 106,109 ****
--- 128,132 ----
      pipe my $reader, my $writer;
  
+     debug( "Trying to fork..." );
      my $pid = fork();
      die "Cannot fork: $!" unless defined( $pid );
***************
*** 112,115 ****
--- 135,139 ----
      if ( $pid == 0 ) {
          close $reader;
+         close $main_sock;
          $writer->autoflush( 1 );
  
***************
*** 121,125 ****
          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
***************
*** 138,142 ****
  
              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;
              }
  
***************
*** 144,157 ****
              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;
      }
***************
*** 163,166 ****
--- 195,199 ----
  
          my $line = <$reader>;
+         debug ( "child said $line" );
          if ( $line =~ /shutdown/ ) {
              close $reader;
***************
*** 171,175 ****
  
  close $main_sock;
! 
  
  # handle_command
--- 204,208 ----
  
  close $main_sock;
! print "\nThe IMAP_test_server is exiting.\n";
  
  # handle_command
***************
*** 186,190 ****
  
      # LOGIN
- 
          # This section is of special importance because the user name given
          # at login determines which stones we throw at IMAP.pm
--- 219,222 ----
***************
*** 204,211 ****
                  # 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 );
                      }
                  }
***************
*** 232,236 ****
  
      # LIST
- 
          if ( $command =~ /^LIST "" "\*"/ && $state ne 'Not Authenticated' ) {
              foreach ( @mailboxes ) {
--- 264,267 ----
***************
*** 249,253 ****
  
      # LOGOUT
- 
          if ( $command =~ /^LOGOUT/ ) {
              print $client "* BYE bye$eol";
--- 280,283 ----
***************
*** 259,268 ****
          }
  
- 
      # 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';
***************
*** 280,292 ****
  
      # 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' ) {
***************
*** 297,308 ****
      # 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";
              }
***************
*** 319,323 ****
              my $uid = $1;
              my $part = $2;
!             
              my $response;
  
--- 344,348 ----
              my $uid = $1;
              my $part = $2;
! 
              my $response;
  
***************
*** 369,373 ****
                  print $client "$tag NO no such message$eol";
              }
!             
              return;
          }
--- 394,398 ----
                  print $client "$tag NO no such message$eol";
              }
! 
              return;
          }
***************
*** 386,391 ****
          }
  
- 
- 
          # If we get here, we don't know the command and say so
  
--- 411,414 ----
***************
*** 403,413 ****
  
  
! 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";
***************
*** 420,454 ****
  
  
! 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';
***************
*** 456,469 ****
              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";
***************
*** 476,486 ****
  
  
! 
! 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 "*" ) {
***************
*** 491,504 ****
          $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";
***************
*** 520,535 ****
          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;
      }
***************
*** 537,545 ****
  
  
! 
! 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";
***************
*** 559,566 ****
  
  
! 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 = '';
***************
*** 572,576 ****
          }
          close MSG;
!         
          return "$response$eol";
      }
--- 594,598 ----
          }
          close MSG;
! 
          return "$response$eol";
      }
***************
*** 580,587 ****
  }
  
! 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 = '';
***************
*** 601,602 ****
--- 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 };
+ }
+ 
+ 
+