No OneTemporary
Actions

Authored By

Unknown

Size

30 KB

Referenced Files

None

Subscribers

None

View Options

	diff --git a/perl/annotator/Daemon.pm b/perl/annotator/Daemon.pm
	index 6ecca07e9..2155f9df9 100755
	--- a/perl/annotator/Daemon.pm
	+++ b/perl/annotator/Daemon.pm
	@@ -1,630 +1,630 @@
	#!/usr/bin/perl -cw
	#
	# Copyright (c) 1994-2011 Carnegie Mellon University. All rights reserved.
	#
	# Redistribution and use in source and binary forms, with or without
	# modification, are permitted provided that the following conditions
	# are met:
	#
	# 1. Redistributions of source code must retain the above copyright
	# notice, this list of conditions and the following disclaimer.
	#
	# 2. 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.
	#
	# 3. The name "Carnegie Mellon University" must not be used to
	# endorse or promote products derived from this software without
	# prior written permission. For permission or any legal
	# details, please contact
	# Carnegie Mellon University
	# Center for Technology Transfer and Enterprise Creation
	# 4615 Forbes Avenue
	# Suite 302
	# Pittsburgh, PA 15213
	# (412) 268-7393, fax: (412) 268-7395
	# innovation@andrew.cmu.edu
	#
	# 4. Redistributions of any form whatsoever must retain the following
	# acknowledgment:
	# "This product includes software developed by Computing Services
	# at Carnegie Mellon University (http://www.cmu.edu/computing/)."
	#
	# CARNEGIE MELLON UNIVERSITY DISCLAIMS ALL WARRANTIES WITH REGARD TO
	# THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY
	# AND FITNESS, IN NO EVENT SHALL CARNEGIE MELLON UNIVERSITY BE LIABLE
	# FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
	# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN
	# AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING
	# OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
	#

	use warnings;
	use strict;
	package Cyrus::Annotator::Daemon;
	use base qw(Net::Server);
	# use Data::Dumper;
	use Unix::Syslog qw(:macros);
	use Cyrus::Annotator::Message;
	use File::Path;
	use Encode qw(decode);

	our $VERSION = '1.00';

	use constant USER => 'cyrus';
	use constant GROUP => 'mail';
	use constant RUNPREFIX => '/var/run/annotatord';
	use constant APPNAME => 'annotatord';
	use constant PIDFILE => RUNPREFIX . '.pid';
	use constant SOCKPATH => RUNPREFIX . '.socket';

	# Levels are: LOG_DEBUG (7), LOG_INFO (6), *LOG_NOTICE (5), LOG_WARNING (4), LOG_ERR (3)
	use constant LOG_LEVEL => LOG_INFO;

	=head1 NAME

	Cyrus::Annotator::Daemon - framework for writing annotator daemons for Cyrus

	=head1 SYNOPSIS

	use warnings;
	use strict;
	package MyAnnotatorDaemon;
	use Cyrus::Annotator::Daemon;
	our @ISA = qw(Cyrus::Annotator::Daemon);

	sub annotate_message
	{
	my ($self, $message) = @_;

	$message->set_flag('\Flagged');
	$message->set_shared_annotation('/comment', 'Hello!!');
	}

	MyAnnotatorDaemon->run();

	=head1 DESCRIPTION

	This module provides a framework for writing daemons which can be used
	to add annotations or flags to messages which are delivered into the
	Cyrus mail server.

	To use Cyrus::Annotator::Daemon, write a Perl script which creates an
	object derived from it; see the Synposis above. Run this script as
	root, and it will daemonize itself. Then add this line to the
	imapd.conf file

	annotation_callout: /var/run/annotatord.socket

	and restart Cyrus.

	=head1 METHODS

	Cyrus::Annotator::Daemon has the following methods.

	=over 4
	=cut

	my @default_args = (
	personality => 'Net::Server',
	appname => APPNAME,

	user => USER,
	group => GROUP,
	pid_file => PIDFILE,
	background => 1,
	size_limit => 256,

	syslog_level => LOG_LEVEL,
	syslog_facility => LOG_LOCAL6,
	syslog_ident => APPNAME,
	log_file => 'Sys::Syslog',

	proto => 'unix',
	port => SOCKPATH . '\|SOCK_STREAM\|unix'
	);

	sub new
	{
	my ($class, @args) = @_;
	my $self = $class->SUPER::new(@args);

	return $self;
	}

	=item I<run(...options...)>

	This class method can be used to create an instance of
	Cyrus::Annotator::Daemon and to run it's main loop. Note that
	Cyrus::Annotator::Daemon derives from Net::Server, and any of that
	module's options can be used.

	For example:

	MyAnnotatorDaemon->run(personality => 'Fork');

	Cyrus::Annotator::Daemon changes some of the Net::Server defaults,
	including:

	=over 4

	=item * Logging is to syslog using facility I<local6>.

	=item * The network socket is a I<SOCK_STREAM> UNIX domain
	socket bound to I</var/run/annotatord.socket>.

	=item * A PID file is written to I</var/run/annotatord.pid>.

	=item * The daemon runs in the background, as user I<cyrus> and group I<mail>.

	=back

	=cut

	sub run
	{
	my ($class, @args) = @_;
	my %aa = (@default_args, @args);
	return $class->SUPER::run(%aa);
	}


	# Can pass a file handle or string
	# Returns two item list of ($ParsedData, $Remainder)
	# All lines must be \r\n terminated

	sub _dlist_parse {
	my $Input = shift;
	my ($Atom, $CurAtom, $Line, @AtomStack) = (undef, undef);
	my $AtomRef = \$Atom;

	if (ref($Input)) {
	$Line = <$Input> \|\| die "No input data: $!";
	} else {
	$Line = $Input;
	}

	# While this is a recursive structure, doing some profiling showed
	# that this call was taking up quite a bit of time in the application
	# I was using this module with. Thus I've tried to optimise the code
	# a bit by turning it into a loop with an explicit stack and keeping
	# the most common cases quick.

	# Always do this once, and keep doing it while we're within
	# a bracketed list of items
	do {

	# Single item? (and any trailing space)
	if ($Line =~ m/\G([^()\"{}\s]+)(?: \|\z\|(?=\)))/gc) {
	# Add to current atom. If there's a stack, must be within a bracket
	if (scalar @AtomStack) {
	push @$AtomRef, $1 eq 'NIL' ? undef : $1;
	} else {
	$$AtomRef = $1 eq 'NIL' ? undef : $1;
	}
	}

	# Quoted section? (but non \" end quote and any trailing space)
	elsif ($Line =~ m/\G"((?:\\.\|[^"])*?)"(?: \|\z\|(?=\)))/gc) {
	# Unquote quoted items
	($CurAtom = $1) =~ s/\\(.)/$1/g;
	# Add to current atom. If there's a stack, must be within a bracket
	if (scalar @AtomStack) {
	push @$AtomRef, $CurAtom;
	} else {
	$$AtomRef = $CurAtom;
	}
	}

	# Bracket?
	elsif ($Line =~ m/\G\(/gc) {
	# Begin a new sub-array
	my $CurAtom = [];
	# Add to current atom. If there's a stack, must be within a bracket
	if (scalar @AtomStack) {
	push @$AtomRef, $CurAtom;
	} else {
	$$AtomRef = $CurAtom;
	}

	# Check for simple response list to fast parse
	if ($Line =~ m/\G([^()\"{}~\s]+(?: [^()\"{}~\s]+)*)\) ?/gc) {
	push @$CurAtom, map { $_ eq 'NIL' ? undef : $_ } split(' ', $1);

	} else {
	# Add current ref to stack and update
	push @AtomStack, $AtomRef;
	$AtomRef = $CurAtom;
	}

	}

	# End bracket? (and possible trailing space)
	elsif ($Line =~ m/\G\) ?/gc) {
	# Close existing sub-array
	if (!scalar @AtomStack) {
	die "Unexpected close bracket in IMAP response : '$Line'";
	}
	$AtomRef = pop @AtomStack;
	}

	# Literal or binary literal? (Must end line)
	elsif ($Line =~ m/\G~?\{(\d+)\}\r\n/gc) {
	my $Bytes = $1;
	$CurAtom = undef;

	# Literal is next $Bytes of data, and possible space
	if (ref($Input)) {
	read($Input, $CurAtom, $Bytes) \|\| die "No input data";
	$Line = <$Input>;
	} else {
	$CurAtom = substr($Line, pos($Line), $Bytes);
	pos($Line) += length($CurAtom);
	}
	$Line =~ m/\G ?/gc;

	# Add to current atom. If there's a stack, must be within a bracket
	if (scalar @AtomStack) {
	push @$AtomRef, $CurAtom;
	} else {
	$$AtomRef = $CurAtom;
	}
	}

	# End of line?
	elsif ($Line =~ m/\G(?:\r\n)?$/gc) {
	# Should not be within brackets
	if (scalar @AtomStack) {
	die "Unexpected end of line in IMAP response : '$Line'";
	}
	# Otherwise fine, we're about to exit anyway
	}

	else {
	die "Error parsing atom in IMAP response : '" . substr($Line, pos($Line), 100) . "'";
	}

	# Repeat while we're within brackets
	} while (scalar @AtomStack);

	my $Remainder = substr($Line, pos($Line));

	return ($Atom, $Remainder);
	}

	sub _parse_list_to_hash {
	my $ContentHashList = shift \|\| [];
	my $Recursive = shift;

	ref($ContentHashList) eq 'ARRAY' \|\| return { };

	my %Res;
	while (@$ContentHashList) {
	my ($Param, $Val) = (shift @$ContentHashList, shift @$ContentHashList);

	$Val = _parse_list_to_hash($Val, $Recursive-1)
	if (ref($Val) && $Recursive);

	$Res{lc($Param)} = $Val;
	}

	return \%Res;
	}

	sub _parse_bodystructure {
	my ($Bs, $IncludeRaw, $DecodeUTF8, $PartNum, $IsMultipart) = @_;
	my %Res;

	# If the first item is a reference, then it's a MIME multipart structure
	if (ref($Bs->[0])) {

	# Multipart items are of the form: [ part 1 ] [ part 2 ] ...
	# "MIME-Subtype" "Content-Type" "Content-Disposition" "Content-Language"

	# Process each mime sub-part recursively
	my ($Part, @SubParts);
	for ($Part = 1; ref($Bs->[0]); $Part++) {
	my $SubPartNum = ($PartNum ? $PartNum . "." : "") . $Part;
	my $Res = _parse_bodystructure(shift(@$Bs), $IncludeRaw, $DecodeUTF8, $SubPartNum, 1);
	push @SubParts, $Res;
	}

	# Setup multi-part hash
	%Res = (
	'MIME-Subparts', \@SubParts,
	'MIME-Type', 'multipart',
	'MIME-Subtype', lc(shift(@$Bs)),
	'Content-Type', _parse_list_to_hash(shift(@$Bs)),
	'Content-Disposition', _parse_list_to_hash(shift(@$Bs), 1),
	'Content-Language', shift(@$Bs),
	'Content-Location', shift(@$Bs),
	# Shouldn't be anything after this. Add as remainder if there is
	'Remainder', $Bs
	);
	}

	# Otherwise it's a normal MIME entity
	else {

	# Get the mime type and sub-type
	my ($MimeType, $MimeSubtype) = (lc(shift(@$Bs)), lc(shift(@$Bs)));

	# Partnum for getting the text part of an entity. Do this
	# here so recursive call works for any embedded messages
	$PartNum = $PartNum ? $PartNum . '.1' : '1'
	if !$IsMultipart;

	# Pull out special fields for 'text' or 'message/rfc822' types
	if ($MimeType eq 'text') {
	%Res = (
	'Lines', splice(@$Bs, 5, 1)
	);
	} elsif ($MimeType eq 'message' && $MimeSubtype eq 'rfc822') {

	# message/rfc822 includes the messages envelope and bodystructure
	my @MsgParts = splice(@$Bs, 5, 3);
	%Res = (
	'Message-Envelope', _parse_envelope(shift(@MsgParts), $IncludeRaw, $DecodeUTF8),
	'Message-Bodystructure', _parse_bodystructure(shift(@MsgParts), $IncludeRaw, $DecodeUTF8, $PartNum),
	'Message-Lines', shift(@MsgParts)
	);
	}

	# All normal mime-entities have these parts
	%Res = (
	%Res,
	'MIME-Type', $MimeType,
	'MIME-Subtype', $MimeSubtype,
	'Content-Type', _parse_list_to_hash(shift(@$Bs)),
	'Content-ID', shift(@$Bs),
	'Content-Description', shift(@$Bs),
	'Content-Transfer-Encoding', shift(@$Bs),
	'Size', shift(@$Bs),
	'Content-MD5', shift(@$Bs),
	'Content-Disposition', _parse_list_to_hash(shift(@$Bs), 1),
	'Content-Language', shift(@$Bs),
	'Content-Location', shift(@$Bs),
	# Shouldn't be anything after this. Add as remainder if there is
	'Remainder', $Bs
	);

	# Extra information for the annotation callout - gnb 20110420
	my $Extra = shift(@$Bs);
	if ($Extra) {
	$Extra = _parse_list_to_hash($Extra, 0);
	# Make casing consistent for users
	$Res{Offset} = $Extra->{offset};
	$Res{HeaderSize} = $Extra->{headersize};
	}

	}

	# Finally set the IMAP body part number and overall mime type
	$Res{'IMAP-Partnum'} = $PartNum \|\| '';
	$Res{'MIME-TxtType'} = $Res{'MIME-Type'} . '/' . $Res{'MIME-Subtype'};

	return \%Res;
	}

	# Regexps used to determine if header is MIME encoded (we remove . from
	# especials because of dumb ANSI_X3.4-1968 encoding)
	-my $RFC1522Token = qr/[^\x00-\x1f\<\>\@\,\;\:\"\/\[\]\?\=\ ]+/;
	-my $NeedDecodeUTF8Regexp = qr/=\?$RFC1522Token\?$RFC1522Token\?[^\?]*\?=/;
	+my $RFC2047Token = qr/[^\x00-\x1f\<\>\@\,\;\:\"\/\[\]\?\=\ ]+/;
	+my $NeedDecodeUTF8Regexp = qr/=\?$RFC2047Token\?$RFC2047Token\?[^\?]*\?=/;

	sub _parse_envelope {
	my ($Env, $IncludeRaw, $DecodeUTF8) = @_;

	# Check envelope assumption
	scalar(@$Env) == 10
	\|\| die "IMAPTalk: Wrong number of fields in envelope structure " . Dumper($Env);

	_decode_utf8($Env->[1]) if $DecodeUTF8 && defined($Env->[1]) && $Env->[1] =~ $NeedDecodeUTF8Regexp;

	# Setup hash directly from envelope structure
	my %Res = (
	'Date', $Env->[0],
	'Subject', $Env->[1],
	'From', _parse_email_address($Env->[2], $DecodeUTF8),
	'Sender', _parse_email_address($Env->[3], $DecodeUTF8),
	'Reply-To', _parse_email_address($Env->[4], $DecodeUTF8),
	'To', _parse_email_address($Env->[5], $DecodeUTF8),
	'Cc', _parse_email_address($Env->[6], $DecodeUTF8),
	'Bcc', _parse_email_address($Env->[7], $DecodeUTF8),
	($IncludeRaw ? (
	'From-Raw', $Env->[2],
	'Sender-Raw', $Env->[3],
	'Reply-To-Raw',$Env->[4],
	'To-Raw', $Env->[5],
	'Cc-Raw', $Env->[6],
	'Bcc-Raw', $Env->[7],
	) : ()),
	'In-Reply-To', $Env->[8],
	'Message-ID', $Env->[9]
	);

	return \%Res;
	}

	sub _parse_email_address {
	my $EmailAddressList = shift \|\| [];
	my $DecodeUTF8 = shift;

	# Email addresses always come as a list of addresses (possibly in groups)
	my @EmailGroups = ([ undef ]);
	foreach my $Adr (@$EmailAddressList) {

	# Check address assumption
	scalar(@$Adr) == 4
	\|\| die "IMAPTalk: Wrong number of fields in email address structure " . Dumper($Adr);

	# No hostname is start/end of group
	if (!defined $Adr->[0] && !defined $Adr->[3]) {
	push @EmailGroups, [ $Adr->[2] ];
	next;
	}

	# Build 'ename@ecorp.com' part
	my $EmailStr = (defined $Adr->[2] ? $Adr->[2] : '')
	. '@'
	. (defined $Adr->[3] ? $Adr->[3] : '');
	# If the email address has a name, add it at the start and put <> around address
	if (defined $Adr->[0] and $Adr->[0] ne '') {
	_decode_utf8($Adr->[0]) if $DecodeUTF8 && $Adr->[0] =~ $NeedDecodeUTF8Regexp;
	# Strip any existing \"'s
	$Adr->[0] =~ s/\"//g;
	$EmailStr = '"' . $Adr->[0] . '" <' . $EmailStr . '>';
	}

	push @{$EmailGroups[-1]}, $EmailStr;
	}

	# Join the results with commas between each address, and "groupname: adrs ;" for groups
	for (@EmailGroups) {
	my $GroupName = shift @$_;
	($_ = undef), next if !defined $GroupName && !@$_;
	my $EmailAdrs = join ", ", @$_;
	$_ = defined($GroupName) ? $GroupName . ': ' . $EmailAdrs . ';' : $EmailAdrs;
	}

	return join " ", grep { defined $_ } @EmailGroups;
	}

	sub _decode_utf8 {
	# Fix dumb, dumb ANSI_X3.4-1968 encoding. It's not actually a valid
	# charset according to RFC2047, "." is an especial, so Encode ignores it
	# See http://en.wikipedia.org/wiki/ASCII for other aliases
	$_[0] =~ s/=\?ANSI_X3\.4-(?:1968\|1986)\?/=?US-ASCII?/gi;
	eval { $_[0] = decode('MIME-Header', $_[0]); };
	}

	sub _read_args
	{
	my $Nbytes;
	my $Data = '';

	for (;;) {
	$Nbytes = readline STDIN;
	last unless defined $Nbytes;
	chomp $Nbytes;
	$Nbytes = 0 + $Nbytes;
	# printf "nbytes=%d\n", $nbytes;
	last if (!$Nbytes);
	read STDIN, $Data, $Nbytes, length($Data);
	}

	return $Data;
	}

	sub _format_string
	{
	my ($s) = @_;

	return "NIL" unless defined $s;

	my $len = length($s);

	if ($len > 1024 \|\| $s =~ m/[\\"\012\015\200-\377]/) {
	# don't try to quote this, use a literal
	return "{$len}\r\n$s";
	}
	else {
	return "\"$s\"";
	}
	}

	sub _emit_results
	{
	my ($self, $message) = @_;
	my @results;
	my $sep = '';

	my ($flags, $annots) = $message->get_changed();

	foreach my $a (@$annots) {
	my ($entry, $type, $value) = @$a;
	my $format_val = _format_string($value);
	push @results, "ANNOTATION ($entry ($type $format_val))";
	}

	foreach my $f (@$flags) {
	my ($name, $set) = @$f;
	my $op = $set ? "+FLAGS" : "-FLAGS";
	push @results, "$op $name";
	}

	print "(" . join(' ', @results) . ")\n";
	}

	sub process_request
	{
	my ($self) = @_;

	eval {
	$self->log(3, "Reading request");
	my $ArgsString = _read_args();
	die "Failed to read args" unless $ArgsString;

	my ($ArgsList, $Remainder) = _dlist_parse($ArgsString);
	die "Failed to parse args $ArgsString" unless $ArgsList;

	my %ArgsHash = @$ArgsList;

	# parse the argshash out here
	$ArgsHash{BODYSTRUCTURE} = _parse_bodystructure(delete $ArgsHash{BODY});

	my $message = Cyrus::Annotator::Message->new(%ArgsHash);

	$self->annotate_message($message);

	$self->log(3, "Emitting result");
	$self->_emit_results($message);
	};
	if ($@) {
	$self->log(2, "Caught and ignored error: $@");
	}
	}

	=item I<annotate_message($message)>

	You need to provide a method of this name. It will be called whenever
	Cyrus notifies the annotator daemon that a new message is available, and
	may set or clear any flags (system or user flags) or annotations. Note
	that to set any annotations which aren't builtin to Cyrus, you will
	first need to configure them using I<annotation_definitions> option in
	the I<imapd.conf> file.

	The I<$message> object is a Cyrus::Annotator::Message which can be
	examined, and on which flags and annotations can be set.

	=cut

	sub annotate_message
	{
	my ($self, $message) = @_;

	die "Please define an annotate_message() sub";
	}

	sub post_configure
	{
	my ($self) = @_;

	unlink(SOCKPATH);

	$self->SUPER::post_configure();
	}

	=back

	=head1 SEE ALSO

	I<Net::Server>, B<imapd.conf>(5), I<RFC3501>, I<RFC5257>.

	=head1 AUTHOR

	Greg Banks E<lt>gnb@fastmail.fmE<gt>.

	=cut

	1;
	diff --git a/perl/annotator/Message.pm b/perl/annotator/Message.pm
	index 041404239..57f35994b 100644
	--- a/perl/annotator/Message.pm
	+++ b/perl/annotator/Message.pm
	@@ -1,480 +1,503 @@
	#!/usr/bin/perl -cw
	#
	# Copyright (c) 1994-2011 Carnegie Mellon University. All rights reserved.
	#
	# Redistribution and use in source and binary forms, with or without
	# modification, are permitted provided that the following conditions
	# are met:
	#
	# 1. Redistributions of source code must retain the above copyright
	# notice, this list of conditions and the following disclaimer.
	#
	# 2. 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.
	#
	# 3. The name "Carnegie Mellon University" must not be used to
	# endorse or promote products derived from this software without
	# prior written permission. For permission or any legal
	# details, please contact
	# Carnegie Mellon University
	# Center for Technology Transfer and Enterprise Creation
	# 4615 Forbes Avenue
	# Suite 302
	# Pittsburgh, PA 15213
	# (412) 268-7393, fax: (412) 268-7395
	# innovation@andrew.cmu.edu
	#
	# 4. Redistributions of any form whatsoever must retain the following
	# acknowledgment:
	# "This product includes software developed by Computing Services
	# at Carnegie Mellon University (http://www.cmu.edu/computing/)."
	#
	# CARNEGIE MELLON UNIVERSITY DISCLAIMS ALL WARRANTIES WITH REGARD TO
	# THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY
	# AND FITNESS, IN NO EVENT SHALL CARNEGIE MELLON UNIVERSITY BE LIABLE
	# FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
	# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN
	# AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING
	# OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
	#
	-
	-use warnings;
	use strict;
	+use warnings;

	package Cyrus::Annotator::Message;

	use MIME::Base64 qw(decode_base64);
	use MIME::QuotedPrint qw(decode_qp);
	use Encode qw(decode);

	our $VERSION = '1.00';

	=head1 NAME

	Cyrus::Annotator::Message - representation of a message to annotate

	=head1 SYNOPSIS

	use warnings;
	use strict;
	package MyAnnotatorDaemon;
	use base Cyrus::Annotator::Daemon;

	sub annotate_message
	{
	my ($message) = @_;

	$message->set_flag('\Flagged');
	$message->set_shared_annotation('/comment', 'Hello!!');
	}

	MyAnnotatorDaemon->run();

	=head1 DESCRIPTION

	This module encapsulates a message which is being processed by the
	annotator daemon.

	=head1 METHODS

	Cyrus::Annotator::Message has the following methods.

	=over 4

	=item I<new(%args)>

	Takes the following args:

	# required
	* BODYSTRUCTURE => parsed bodystructure

	# optional (but you need to provide SOMETHING if your code uses any
	# of the accessors)
	* GUID => 40 character sha1
	* HEADER => Mail::Header object with headers pre-parsed
	* FILENAME => path to rfc822 file

	# totally optional (will be considered empty if not set)
	* FLAGS => array of already set flags
	- * ANNOTATAIONS => array of already set annotations
	+ * ANNOTATIONS => array of already set annotations

	=cut

	sub new {
	my $class = shift;
	my %args = @_;

	my %flags;
	my %annots;

	my $fs = $args{FLAGS} \|\| [];
	- my $as = $args{ANNOTATAIONS} \|\| [];
	+ my $as = $args{ANNOTATIONS} \|\| [];

	for my $name (@$fs) {
	$flags{$name} = {
	value => 1,
	orig => 1,
	};
	}

	- for my $obj (@$as) {
	- my ($entry, $type, $value) = @$obj;
	+ while (my $entry = shift @$as) {
	+ my $rest = shift @$as;
	+ my ($type, $value) = @$rest;
	$annots{$entry}{$type} = {
	value => $value,
	orig => $value,
	};
	}

	my $self = bless {
	filename => $args{FILENAME},
	bodystructure => $args{BODYSTRUCTURE},
	guid => $args{GUID},
	header => $args{HEADER},
	flag => \%flags,
	annot => \%annots,
	}, ref($class) \|\| $class;
	}


	=item I<fh()>

	returns a read-only filehandle to the raw (rfc822) representation
	of the full message.

	=cut

	sub fh {
	my $self = shift;

	unless ($self->{fh}) {
	die "Need a filename" unless $self->{filename};
	require "IO/File.pm";
	$self->{fh} = IO::File->new($self->{filename}, 'r');
	}

	# Move back to start of message
	seek $self->{fh}, 0, 0;

	return $self->{fh};
	}

	=item I<decode_part($Part, $Content)>

	Given some content, decode it from the part's content
	encoding and charset.

	=cut

	sub decode_part {
	my $self = shift;
	my ($Part, $Content) = @_;

	if (lc $Part->{'Content-Transfer-Encoding'} eq 'base64') {
	# remove trailing partial value
	$Content =~ tr{[A-Za-z0-9+/=]}{}cd;
	my $extra = length($Content) % 4;
	if ($extra) {
	# warn "stripping $extra chars " . length($Content);
	$Content = substr($Content, 0, -$extra);
	}
	$Content = decode_base64($Content);
	}
	elsif (lc $Part->{'Content-Transfer-Encoding'} eq 'quoted-printable') {
	# remove trailing partial value
	$Content =~ s/=.?$//;
	$Content = decode_qp($Content);
	}

	- my $charset = $Part->{'Content-Type'}{charset} \|\| 'iso-8859-1';
	+ my $charset = lc($Part->{'Content-Type'}{charset} \|\| 'iso-8859-1');
	+
	+ # If no charset is present, it defaults to ascii. But some systems
	+ # send 8-bit data. For them, assume iso-8859-1, ascii is a subset anyway
	+ $charset = 'iso-8859-1'
	+ if $charset eq 'ascii' \|\| $charset eq 'us-ascii';
	+
	+ # Fix up some bogus formatted iso charsets
	+ $charset =~ s/^(iso)[\-_]?(\d+)[\-_](\d+)[\-_]?\w*/$1-$2-$3/i;

	return eval { decode($charset, $Content) } \|\| decode('iso-8859-1', $Content);
	}

	=item I<read_part_content($Part, $nbytes)>

	returns the first n bytes of the bodypart passed. This is a section of the
	bodystructure (hashref). If no part is passed, it's the raw message.

	If no 'nbytes' is passed, read the entire part.

	=cut

	sub read_part_content {
	my $self = shift;
	my ($Part, $nbytes) = @_;

	unless ($Part) {
	$Part = $self->bodystructure();
	}

	my $fh = $self->fh();

	die "No Offset for part"
	unless defined $Part->{Offset};
	die "No Size for part"
	unless defined $Part->{Size};

	- unless (defined $nbytes and $nbytes > $Part->{Size}) {
	+ if (!defined($nbytes) \|\| $Part->{Size} < $nbytes) {
	$nbytes = $Part->{Size};
	}

	seek $fh, $Part->{Offset}, 0
	or die "Cannot seek: $!";

	my $Content = '';

	# Could be 0 length body, only die on undef (real error)
	my $r = read($fh, $Content, $nbytes);
	die "Cannot read: $!" if !defined $r;

	return $self->decode_part($Part, $Content);
	}

	=item I<header()>

	returns a Mail::Header object containing all the headers of the message.

	=cut

	sub header {
	my $self = shift;

	unless ($self->{header}) {
	require "Mail/Header.pm";
	$self->{header} = Mail::Header->new($self->fh());
	}

	return $self->{header};
	}

	=item I<bodystructure()>

	returns a structure

	is a structure closely based on the IMAP BODYSTRUCTURE, decoded into a
	hash, including recursively all MIME sections. In general, the
	following items are defined for all body structures:

	=over 4

	=item * MIME-Type

	=item * MIME-Subtype

	=item * Content-Type

	=item * Content-Description

	=item * Content-Dispositon

	=item * Content-Language

	=back

	Body structures which have a MIME-Type of 'multipart' contain the
	following items:

	=over 4

	=item * MIME-Subparts

	=back

	For body structures B<except> those that have a MIME-Type of
	'multipart', the following are defined:

	=over 4

	=item * Content-ID

	=item * Content-Description

	=item * Content-Transfer-Encoding

	=item * Content-MD5

	=item * Size

	=item * Lines

	=item * Offset

	=item * HeaderSize

	=back

	=item I<guid()>

	returns the hex encoded (40 character) sha1 of the rfc822 representation.

	=item I<has_flag($name)>

	=item I<set_flag($name)>

	=item I<clear_flag($name)>

	Check for the boolean value of a flag with $name, set the flag and remove
	the flag respectively.

	Note that changes are not immediate. They will be applied by the annotator
	at the end.

	For example:

	$message->set_flag("\\Flagged");

	=cut

	sub bodystructure {
	my $self = shift;
	return $self->{bodystructure};
	}


	sub get_flag {
	my $self = shift;
	my ($name) = @_;

	return $self->{flag}{$name}{value};
	}

	+sub get_flags {
	+ my $self = shift;
	+ return grep { $self->{flag}{$_}{value} } keys %{$self->{flag}};
	+}
	+
	sub set_flag_value {
	my $self = shift;
	my ($name, $value) = @_;
	$self->{flag}{$name}{orig} = 0
	unless exists $self->{flag}{$name}{orig};
	$self->{flag}{$name}{value} = $value;
	}

	sub set_flag {
	my $self = shift;
	my ($name) = @_;
	$self->set_flag_value($name, 1);
	}

	sub clear_flag {
	my $self = shift;
	my ($name) = @_;
	$self->set_flag_value($name, 0);
	}

	=item I<get_shared_annotation($entry)>

	=item I<get_private_annotation($entry)>

	=item I<set_shared_annotation($entry, $value)>

	=item I<set_private_annotation($entry, $value)>

	=item I<clear_shared_annotation($entry)>

	=item I<clear_private_annotation($entry)>

	Get, set and clear the value of an annotation, either shared or private. The
	"get" accessors return a string with the value. Clear is the same as set
	with $value of the empty string ('').

	For example:

	$message->set_shared_annotation('/comment', 'Hello World');

	=cut

	sub get_annotation {
	my $self = shift;
	my ($entry, $type) = @_;

	return $self->{annot}{$entry}{$type}{value};
	}

	sub set_annotation {
	my $self = shift;
	my ($entry, $type, $value) = @_;
	$value = '' unless defined $value;
	$self->{annot}{$entry}{$type}{orig} = ''
	unless exists $self->{annot}{$entry}{$type}{orig};
	$self->{annot}{$entry}{$type}{value} = $value;
	}

	sub get_shared_annotation {
	my $self = shift;
	my ($entry) = @_;
	return $self->get_annotation($entry, 'value.shared');
	}

	sub set_shared_annotation {
	my $self = shift;
	my ($entry, $value) = @_;
	return $self->set_annotation($entry, 'value.shared', $value);
	}

	sub clear_shared_annotation {
	my $self = shift;
	my ($entry) = @_;
	return $self->set_annotation($entry, 'value.shared', '');
	}

	sub get_private_annotation {
	my $self = shift;
	my ($entry) = @_;
	return $self->get_annotation($entry, 'value.private');
	}

	sub set_private_annotation {
	my $self = shift;
	my ($entry, $value) = @_;
	return $self->set_annotation($entry, 'value.private', $value);
	}

	sub clear_private_annotation {
	my $self = shift;
	my ($entry) = @_;
	return $self->set_annotation($entry, 'value.private', '');
	}

	=item I<get_changed()>

	returns two arrayrefs - [['flagname', 'bool']] and [['entry', 'type', 'value']], e.g.

	[["\\Flagged", 1]], [['/comment', 'value.shared', 'Hello World']]

	=cut

	sub get_changed {
	my $self = shift;
	my @flags;
	my @annots;

	foreach my $name (sort keys %{$self->{flag}}) {
	my $item = $self->{flag}{$name};
	push @flags, [$name, $item->{value}]
	unless $item->{value} == $item->{orig};
	}

	foreach my $entry (sort keys %{$self->{annot}}) {
	foreach my $type (sort keys %{$self->{annot}{$entry}}) {
	my $item = $self->{annot}{$entry}{$type};
	push @annots, [$entry, $type, $item->{value}]
	- unless $item->{value} eq $item->{orig};
	+ unless is_eq($item->{value}, $item->{orig});
	}
	}

	return (\@flags, \@annots);
	}

	+sub is_eq {
	+ my ($l, $r) = @_;
	+ if (defined $l && defined $r) {
	+ return $l eq $r;
	+ }
	+ else {
	+ return !defined $l && !defined $r;
	+ }
	+}
	+
	=back

	=head1 SEE ALSO

	I<RFC3501>, I<RFC5257>.

	=head1 AUTHOR

	Greg Banks E<lt>gnb@fastmail.fmE<gt>.
	Bron Gondwana E<lt>brong@fastmail.fmE<gt>.

	=cut

	1;

File Metadata

Mime Type: text/x-diff
Expires: Mon, Apr 6, 12:49 AM (5 d, 5 h ago)
Storage Engine: blob
Storage Format: Raw Data
Storage Handle: 18831755
Default Alt Text: (30 KB)

No OneTemporaryActions

View Options

File Metadata

Event Timeline

No OneTemporary
Actions