File Coverage

blib/lib/Mail/Ezmlm/Archive.pm

Criterion	Covered	Total	%
statement	6	81	7.4
branch	0	16	0.0
condition	0	8	0.0
subroutine	2	13	15.3
pod	1	9	11.1
total	9	127	7.0

# ===========================================================================
# Mail::Ezmlm::Archive
#
# Object methods for ezmlm-idx archives
#
# Copyright (C) 2003-2005, Alessandro Ranellucci, All Rights Reserved.
# Please send bug reports and comments to
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions are
# met:
#
# Redistributions of source code must retain the above copyright notice,
# this list of conditions and the following disclaimer.
#
# Redistributions in binary form must reproduce the above copyright notice,
# this list of conditions and the following disclaimer in the documentation
# and/or other materials provided with the distribution.
#
# Neither name Alessandro Ranellucci nor the names of any contributors
# may be used to endorse or promote products derived from this software
# without specific prior written permission.
#
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
# IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
# THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
# PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE
# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
#
# ==========================================================================
# POD is at the end of this file. Search for '=head' to find it

package Mail::Ezmlm::Archive;

use strict;
use vars qw($VERSION *MONTHS);
require 5.002;

$VERSION = '0.16';

%MONTHS = ( Jan => 1, Feb => 2, Mar => 3, Apr => 4, May => 5, Jun => 6,
			Jul => 7, Aug => 8, Sep => 9, Oct => 10, Nov => 11, Dec => 12 );

sub new {
	my ($class, $list) = @_;
	my $self = {};
	bless $self, ref $class || $class || 'Mail::Ezmlm::Archive';
	$self->{CACHE} = 1;
	$self->{CACHED} = {};
	$self->setlist($list) || return undef;
	return $self;
}

sub setlist {
	my ($self, $list) = @_;
	return undef if (!-e "$list/lock" || !-e "$list/archived" || !-e "$list/indexed");
	return ($self->{LIST_PATH} = $list);
}

sub cache {
	my $self = shift;
	$self->{CACHE} = 0;
}

sub nocache {
	my $self = shift;
	$self->{CACHE} = 1;
}

sub getmonths {
	my $self = shift;
	opendir(THREADS, $self->{LIST_PATH} . '/archive/threads');
	my @months = grep /^\d{6}$/, readdir(THREADS);
	closedir(THREADS);
	return sort(@months);
}

sub getthreads {
	my ($self, $month) = @_;
	my @threadlist = $self->_get_file($self->{LIST_PATH} . "/archive/threads/$month");
	my $threads = [];
	foreach my $thread (@threadlist) {
		$thread =~ m/^(\d+):(\w+) \[(\d+)\] (.*)$/;
		push (@{$threads}, {
			subject => $4,
			count => $3,
			offset => $1,
			id => $2,
			date => $self->_get_date($1)
		});
	}
	return $threads;
}

sub getthread {
	my ($self, $thread) = @_;
	my ($a, $b) = (substr($thread,0,2), substr($thread,2));
	my @messages = $self->_get_file($self->{LIST_PATH} . "/archive/subjects/$a/$b");
	my $subject = shift(@messages);
	chop($subject);
	$subject =~ s/^\w+ //;
	my $messages = [];
	foreach my $message (@messages) {
		$message =~ m/^(\d+):(\d+):(\w+) (.*)$/ || next;
		push (@{$messages}, {
			id => $1,
			month => $2,
			authorid => $3,
			author => $4
		});
	}
	return {
		subject => $subject,
		messages => $messages
	};
}

sub getmessage {
	my ($self, $message) = @_;
	$message = sprintf("%03u", $message);
	$message =~ m/^(\d+)(\d{2})$/;
	my ($a, $b) = ($1, $2);
	return undef unless (-e $self->{LIST_PATH} . "/archive/$a/$b");
	my @lines = $self->_get_file($self->{LIST_PATH} . "/archive/$a/$b");
	my $date = $self->_get_date(1*$message);
	$date =~ m/\s([A-Z][a-z]{2})\s(\d{4})/;
	return {
		month => $2 . sprintf("%02u", $MONTHS{$1}),
		text => join("", @lines)
	};
}

sub getcount {
	my $self = shift;
	open(FILE, $self->{LIST_PATH} . "/num");
	 =~ m/^(\d+):/;
 	my $count = $1;
	close(FILE);
	return $count;
}

sub _get_file {
	my ($self, $file) = @_;
	if ($self->{CACHED}->{$file}) {
		return @{$self->{CACHED}->{$file}};
	}
	open(FH, "<$file");
	my @lines = ;
	close(FH);
	if ($self->{CACHE} == 1) {
		$self->{CACHED}->{$file} = [ @lines ];
	}
	return @lines;
}

sub _get_date {
	my ($self, $message) = @_;
	my $msg = sprintf("%03u", $message);
	$msg =~ m/^(\d+)(\d{2})$/;
	my ($a, $b) = ($1, $2);
	my @index = $self->_get_file($self->{LIST_PATH} . "/archive/$a/index");
	my $found;
	foreach my $line (@index) {
		if ($found) {
			$line =~ m/^\s([^;]+);/;
			return $1;
		}
		$found = 1 if ($line =~ /^$message:/);
	}
}

1;
__END__