Mail::Folder::Maildir - A maildir folder interface for Mail::Folder.

# -*-perl-*-
#
# Copyright (c) 1996-1998 Kevin Johnson <kjj@pobox.com>.
#
# All rights reserved. This program is free software; you can
# redistribute it and/or modify it under the same terms as Perl
# itself.
#
# $Id: Maildir.pm,v 1.4 1998/04/05 17:21:53 kjj Exp $

require 5.00397;
package Mail::Folder::Maildir;
use strict;
use POSIX qw(ENOENT);
use vars qw($VERSION @ISA);

@ISA = qw(Mail::Folder);
$VERSION = "0.07";

Mail::Folder->register_type('maildir');

my $counter = 0;

use Mail::Folder;
use Mail::Internet;
use Mail::Header;
use Mail::Address;
use Sys::Hostname;
use IO::File;
use DirHandle;
use File::Sync qw(fsync);

use Carp;

sub open {
  my $self = shift;
  my $foldername = shift;

  return 0 unless $self->SUPER::open($foldername);

  is_valid_folder_format($foldername)
    or croak "$foldername isn't an maildir folder";

  if (($< == 0) || ($> == 0)) {
    $self->set_readonly unless ((stat($foldername))[2] & 0200);
  } else {
    $self->set_readonly unless (-w $foldername);
  }

  $self->_absorb_folder($foldername);

  $self->current_message(1);

  return 1;
}

sub close {
  my $self = shift;

  delete $self->{MAILDIR_MsgFiles};
  return $self->SUPER::close;
}

sub sync {
  my $self = shift;

  my $qty_new_messages = 0;
  my @deletes = $self->select_label('deleted');
  my $foldername = $self->foldername;

  return -1 if ($self->SUPER::sync == -1);

  $self->_absorb_folder($foldername);

  unless ($self->is_readonly) {
    if (@deletes) {
      # we need to diddle current_message if it's pointing to a deleted msg
      my $msg = $self->current_message;
      while ($msg >= $self->first_message) {
	last if (!$self->label_exists($msg, 'deleted'));
	$msg = $self->prev_message($msg);
      }
      $self->current_message($msg);

      unlink(map { "$foldername/$self->{Messages}{$_}{Filename}" } @deletes);
      for my $msg (@deletes) {
	$self->forget_message($msg);
      }
      $self->clear_label('deleted');
    }
  }

  $self->_maildir_update_info unless ($self->is_readonly ||
				      $self->get_option('NotMUA'));

  return $qty_new_messages;
}

sub pack {
  my $self = shift;

  my $newmsg = 0;
  my $current_message = $self->current_message;

  return 0 if (!$self->SUPER::pack || $self->is_readonly);

  for my $msg (sort { $a <=> $b } $self->message_list) {
    $newmsg++;
    if ($msg > $newmsg) {
      $self->current_message($newmsg) if ($msg == $current_message);
      $self->remember_message($newmsg);
      $self->cache_header($newmsg, $self->{Messages}{$msg}{Header});
      $self->forget_message($msg);
    }
  }
  return 1;
}

sub get_message {
  my $self = shift;
  my $key = shift;
  
  return undef unless $self->SUPER::get_message($key);
  
  my $filename = $self->foldername . "/$self->{Messages}{$key}{Filename}";
  my $fh = new IO::File $filename or croak "can't open $filename: $!";
  my $mref = new Mail::Internet($fh,
				Modify => 0,
				MailFrom => 'COERCE');
  $fh->close;

  my $href = $mref->head;
  $self->cache_header($key, $href);
  $self->add_label($key, 'seen');

  return $mref;
}

sub get_message_file {
  my $self = shift;
  my $key = shift;
  
  return undef unless $self->SUPER::get_message_file($key);
  
  return($self->foldername . "/$self->{Messages}{$key}{Filename}");
}

sub get_header {
  my $self = shift;
  my $key = shift;
  
  my $hdr = $self->SUPER::get_header($key);
  return $hdr if defined($hdr);
  
  # return undef unless ($self->SUPER::get_header($key));
  
  # return $self->{Messages}{$key}{Header} if ($self->{Messages}{$key}{Header});
  
  my $filename = $self->foldername . "/$self->{Messages}{$key}{Filename}";

  my $fh = new IO::File $filename or return undef;
  my $href = new Mail::Header($fh,
			      Modify => 0,
			      MailFrom => 'COERCE');
  $fh->close;

  $self->cache_header($key, $href);

  return $href;
}

sub append_message {
  my $self = shift;
  my $mref = shift;

  my $folder = $self->foldername;
  my $msg_num = $self->last_message;

  my $dup_mref = $mref->dup;

  return 0 unless $self->SUPER::append_message($dup_mref);

  $msg_num++;
  $dup_mref->delete('From ');
  
  my $tmpfile = $self->_get_tmp_file()
    or croak "timed out trying to create a file in $folder/tmp";
  my $fh = new IO::File "$folder/tmp/$tmpfile", O_CREAT|O_WRONLY, 0600
    or croak "can't create $folder/tmp/$tmpfile: $!";
  $fh->autoflush(1);
  _coerce_header($dup_mref);
  $dup_mref->print($fh) or croak "failed writing $folder/tmp/$tmpfile: $!";
  fsync($fh) or croak "failed fsyncing $folder/tmp/$tmpfile: $!";
  $fh->close or croak "failed closing $folder/tmp/$tmpfile: $!";

  link("$folder/tmp/$tmpfile", "$folder/cur/$tmpfile")
    or croak "can't link $folder/tmp/$tmpfile to $folder/cur/$tmpfile for append method: $!";
  unlink("$folder/tmp/$tmpfile")
    or croak "can't unlink $folder/tmp/$tmpfile for append method: $!";

  $self->remember_message($msg_num);
  $self->cache_header($msg_num, $dup_mref->head);
  $self->{MAILDIR_MsgFiles}{$tmpfile} = $msg_num; # file to msgnum mapping
  $self->{Messages}{$msg_num}{Filename} = "cur/$tmpfile";

  return 1;
}

sub update_message {
  my $self = shift;
  my $key = shift;
  my $mref = shift;

  my $folder = $self->foldername;
  my $dup_mref = $mref->dup;

  return 0 unless $self->SUPER::update_message($key, $dup_mref);

  $dup_mref->delete('From ');

  my $tmpfile = $self->_get_tmp_file()
    or croak "timed out trying to create a tmpfile";
  my $fh = new IO::File $tmpfile, O_CREAT|O_WRONLY, 0600
    or croak "can't create $tmpfile: $!";
  $fh->autoflush(1);
  _coerce_header($dup_mref);
  $dup_mref->print($fh) or croak "failed writing $tmpfile: $!";
  fsync($fh) or croak "failed fsyncing $tmpfile: $!";
  $fh->close or croak "failed closing $tmpfile: $!";

  rename($tmpfile, "$folder/$self->{Messages}{$key}{Filename}") or
    croak "can't rename $tmpfile to $folder/$self->{Messages}{$key}{Filename}: $!";

  return 1;
}

sub is_valid_folder_format {
  my $foldername = shift;

  return 0 unless (-d $foldername &&
		   -d "$foldername/tmp" &&
		   -d "$foldername/cur" &&
		   -d "$foldername/new");
  return 1;
}

sub create {
  my $self = shift;
  my $foldername = shift;

  return 0 if (-e $foldername);

  mkdir($foldername, 0700) or croak "can't create $foldername: $!";
  mkdir("$foldername/cur", 0700);
  mkdir("$foldername/new", 0700);
  mkdir("$foldername/tmp", 0700);
  return 1;
}
###############################################################################
sub _coerce_header {
  my $mref = shift;
  my $from = '';

  if ($mref->head->count('Return-Path') == 0) {
    if ($from =
	$mref->get('Reply-To') ||
	$mref->get('From') ||
	$mref->get('Sender')) {	# this is dubious
      my @addrs = Mail::Address->parse($from);
      $from = $addrs[0]->address();
      $mref->add('Return-Path', "<$from>", 0);
    } else {
      croak "can't synthesize Return-Path";
    }
  }

  return $mref;
}

# this returns the name of a newly create file in the folder tmp
# directory following the qmail rules for it's creation.

sub _get_tmp_file {
  my $self = shift;
  my $folder = $self->foldername;
  my $filename = '';
  my $counter = $self->_bump_counter;

  my $hostname = hostname or croak "can't determine hostname: $!";
  # this loop duration should be configurable, but it's according to spec
  for my $num (1 .. 30) {
    my $time = time;
    $filename = "$time.$$" . "_$counter.$hostname";
    if (stat("$folder/tmp/$filename") || ($! != ENOENT)) {
      select(undef, undef, undef, 2.0);
      next;
    }
    my $fh = new IO::File "$folder/tmp/$filename", O_CREAT|O_WRONLY, 0600
      or croak "can't create $folder/tmp/$filename: $!";
    $fh->close;
    return $filename;
  }

  return undef;
}

sub _bump_counter {
  # my $self = shift;
  return $counter++;
}

sub _maildir_update_info {
  my $self = shift;

  my $foldername = $self->foldername;

  for my $msg ($self->message_list) {
    my $file = $self->{Messages}{$msg}{Filename};
    my $uniqpart = $file; $uniqpart =~ s/:.*$//;
    my $oldinfo = '';
    my $newinfo = '';
    $newinfo .= 'F' if ($self->label_exists($msg, 'flagged'));
    $newinfo .= 'R' if ($self->label_exists($msg, 'replied'));
    $newinfo .= 'S' if ($self->label_exists($msg, 'seen'));
    next if (($file =~ /:/) && ($file !~ /:2,/));
    if ($file =~ /:(.*)/) {
      $oldinfo = $1;
    }
    if ($oldinfo ne $newinfo) {
      my $newfile = "$uniqpart:2,$newinfo";
      croak "can't rename $foldername/$file to $foldername/$newfile: $!"
	unless (rename("$foldername/$file", "$foldername/$newfile"));
      $self->{Messages}{$msg}{Filename} = $newfile;
      delete $self->{MAILDIR_MsgFiles}{$file};
      $self->{MAILDIR_MsgFiles}{$newfile} = $msg;
    }
  }
}

sub _maildir_clean {
  my $foldername = shift;

  my @statary;
  my $time = time;
  my $tmpdir = "$foldername/tmp";

  my $dir = new DirHandle $tmpdir or croak "can't open $tmpdir: $!";
  my @files = $dir->read;
  $dir->close;

  for my $file (@files) {
    next if ($file =~ /^\./);	# per djb, skip filenames that start with "."
    unlink("$tmpdir/$file") if ((@statary = stat("$tmpdir/$file")) &&
				($statary[9] + 129600) < $time);
  }
}

sub _maildir_move_new_to_cur {
  my $foldername = shift;

  my @newfiles;

  my $dir = new DirHandle "$foldername/new"
    or croak"can't open $foldername/new: $!";
  my @files = $dir->read;
  $dir->close;

  for my $file (@files) {
    next if ($file =~ /^\./);
    unlink("$foldername/new/$file")
      if (link("$foldername/new/$file", "$foldername/cur/$file"));
    push(@newfiles, $file);
  }
  return(@newfiles);
}

sub _absorb_folder {
  my $self = shift;
  my $folder_dir = shift;
  my $msg_num = $self->last_message;
  
  _maildir_clean($folder_dir);

  _maildir_move_new_to_cur($folder_dir);

  my $dir = new DirHandle "$folder_dir/cur"
    or croak "can't open $folder_dir/cur: $!";
  my @files = sort map { "cur/$_" } grep((!/^\./ &&
					  !/^RCS$/ &&
					  -f "$folder_dir/cur/$_"),
					 $dir->read);
  $dir->close;
  if (0) {
    $dir = new DirHandle "$folder_dir/new"
      or croak "can't open $folder_dir/new: $!";
    push @files, sort map { "new/$_" } grep((!/^\./ &&
					     !/^RCS$/ &&
					     -f "$folder_dir/new/$_"),
					    $dir->read);
    $dir->close;
  }

  for my $file (@files) {
    next if defined($self->{MAILDIR_MsgFiles}{$file});
    $msg_num++;
    $self->remember_message($msg_num);
    $self->{MAILDIR_MsgFiles}{$file} = $msg_num; # file-to-msgnum mapping
    $self->{Messages}{$msg_num}{Filename} = $file;

    next unless ($file =~ /:(.+)$/); # no info field

    my $info = $1;
    next unless ($info =~ /^2,/); # do we know this info field structure?

    $self->add_label($msg_num, 'flagged') if ($info =~ /F/);
    $self->add_label($msg_num, 'replied') if ($info =~ /R/);
    $self->add_label($msg_num, 'seen') if ($info =~ /S/);
    $self->delete_message($msg_num) if ($info =~ /T/);
				# Not convinced we should do this...
  }
}

###############################################################################

1;