# vim: set cindent expandtab ts=4 sw=4:
#
# Copyright (c) 1998-2005 Chi-Keung Ho. All rights reserved.
#
# This programe is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
#
# Extmail - a high-performance webmail to maildir
# $Id$
package Ext::App::Compose;
use strict;
use Exporter;
use vars qw($VERSION);
use vars qw(@ISA @EXPORT $usercfg $tmp_draft);
@ISA = qw(Exporter Ext::App);
$usercfg = undef;
$tmp_draft = undef;
use Fcntl qw(:flock);
use Ext::App;
use Ext::MIME;
use Ext::Storage::Maildir;
use Ext::CGI; # import $CRLF
use Ext::Utils;
use Ext::Abook;
use Ext::RFC822; # import rfc822_* func
use MIME::Base64; # XXX use XS if possible, perl version sucks
use MIME::QuotedPrint;
use vars qw(%lang_compose $lang_charset);
use Ext::Lang;
use Ext::Unicode;
use Encode::PPUniDetector;
# import from Ext::App
$VERSION = $Ext::App::VERSION;
sub init {
my $self = shift;
$self->SUPER::init(@_);
return unless($self->valid||$self->permit);
$self->add_methods(edit_compose => \&edit_compose); # no draft
$self->add_methods(edit_drafts => \&edit_drafts); # has draft
$self->add_methods(attach_mgr => \&attach_mgr); # alias
$self->add_methods(edit_reply => \&edit_reply); # reply
$self->add_methods(edit_forward => \&edit_forward); # forward
$self->add_methods(edit_import => \&edit_import); # import attaches!
$self->{default_mode} = 'edit_compose';
Ext::Storage::Maildir::init($self->get_working_path);
Ext::MIME::init(path => $self->get_working_path);
# load usercfg from App.pm userconfig(), it will initialize everything.
$usercfg = $self->userconfig;
$self->_initme;
$self;
}
sub _initme {
initlang($_[0]->userconfig->{lang}, __PACKAGE__);
$_[0]->{tpl}->assign( lang_charset => $lang_charset );
$_[0]->{tpl}->assign( \%lang_compose );
}
# edit_compose - write a new email message, dummy function
sub edit_compose {
my $self = shift;
my $q = $self->{query};
my $tpl = $self->{tpl};
#$tpl->assign(SID => $q->cgi('sid'));
$tpl->assign(FOLDER => $q->cgi('folder'));
$tpl->assign(
TO => html_fmt($q->cgi('to')),
CC => html_fmt($q->cgi('cc')),
BCC => html_fmt($q->cgi('bcc')),
SUBJECT => html_fmt($q->cgi('subject')),
CCSENT => $usercfg->{'ccsent'},
BODY => "\n\n". $self->get_signature,
RTE_ON => $usercfg->{compose_html} ? 1 : 0,
BODY_IS_HTML => $usercfg->{compose_html} ? 1 : 0,
);
1;
}
# CORE function for message compose/rewrite XXX
sub edit_drafts {
my $self = shift;
my $tpl = $self->{tpl};
my $q = $self->{query};
my $sid = $self->{sid};
my $draft = $q->cgi('draft') ? $q->cgi('draft') : undef;
$tpl->assign(
SID => $sid,
CCSENT => $usercfg->{'ccsent'},
RTE_ON => $usercfg->{'compose_html'} ? 1 : 0,
);
if($self->submited) {
if($q->cgi('dosave')) {
$self->rebuild_attach('update');
$tpl->assign(FOLDER => 'Drafts');
# XXX call attach_mgr() now
$self->attach_mgr();
# show attach now
# on the first time no new draft create, we should
# use $tmp_draft instead of draft
$draft = $tmp_draft if ($tmp_draft);
$self->show_attach('.Drafts/cur/'.$draft);
reset_working_path();
$tpl->{template} = 'saveok.html';
}elsif($q->cgi('dosend')) {
$self->rebuild_attach('update');
my $newdraft = $self->attach_mgr();
$tpl->assign(FOLDER => 'Drafts');
if ($newdraft) {
$self->sendmail($newdraft) unless ($self->{_errmsg});
} else {
$self->error('SendMail Error: Disk full or filesystem error');
return;
}
reset_working_path();
$tpl->{template} = 'sendok.html';
}elsif($q->cgi('attachmgr')) { # it's a hidden field
if($q->cgi('return')) {
# back to compose
$self->show_draft($draft);
return;
}
if($draft) {
$tpl->assign(HAVE_DRAFT => 1, DRAFT => $draft);
}
$self->rebuild_attach('update');
reset_working_path();
$tpl->{template} = 'attachmgr.html';
}else {
$self->error('Sucks, no valid __mode specify');
return;
}
}else {
if($draft) {
$self->show_draft($draft);
}else {
$self->error('No draft specify or no such draft');
}
}
}
sub edit_forward {
my $self = shift;
my $tpl = $self->{tpl};
my $q = $self->{query};
my $folder = $q->cgi('folder') || 'Inbox';
my $pos = $q->cgi('pos') || 0;
my $file = _name2mdir($folder).'/cur/'.pos2file($folder, $pos);
my $parts = get_msg_info($file);
my $hdr = $parts->{head}{hash};
# UTF-8 handling
my $utf8 = Ext::Unicode->new;
my $charset = hdr_get_hash('Charset', %$hdr);
$utf8->set_charset($charset);
my $subj = decode_words_utf8(hdr_get_hash('Subject', %$hdr));
my $from = decode_words_utf8(hdr_get_hash('From', %$hdr));
my $oldto = decode_words_utf8(hdr_get_hash('To', %$hdr));
my $as_attach = $q->cgi('asattach') || 0; # default to 0
my $has_attach = 0; # XXX default to false
my $boundary = undef;
my $tmpdraft = _gen_maildir_filename();
my $nick = $usercfg->{'nick_name'} || rfc822_addr_parse($ENV{USERNAME})->{name};
my $pftype = $usercfg->{compose_html} ? 'text/html' : 'text/plain';
my $bodyref = _getbody($parts, $file, $pftype);
my $part0;
if ($pftype =~ /$bodyref->{type}/i) {
# yes we found the prefered type
if ($bodyref->{id} >=0) {
$part0 = ${$parts->{body}{list}}[$bodyref->{id}];
} else {
$part0 = {};
}
} else {
# oops, we fallback to the first part
$part0 = ${$parts->{body}{list}}[0];
}
my $obody_type = hdr_get_hash('Content-Type', %{$part0->{phead}}) || 'text/plain';
my $sjchar;
TRY: {
my $subject = decode_words(hdr_get_hash('Subject', %$hdr));
$subject =~ s/\s+//; # remove space
my $c = charset_detect($subject);
if ($c =~ /^(windows-1252|iso-8859-)/ && length $subject < 6) {
$sjchar = charset_detect(decode_words(hdr_get_hash('From', %$hdr)));
} else {
$sjchar = $c;
}
}
$subj = iconv($subj, $sjchar, 'utf-8') if charset_detect($subj) ne 'utf-8';
$from = iconv($from, $sjchar, 'utf-8') if charset_detect($from) ne 'utf-8';
# XXX FIXME terrible bad perl code to do encoding detect, wait for rewrite :(
my $chst;
{
my $tmp_body = '';
# doing urgly checks :(
if ($bodyref->{id}>=0) {
$tmp_body = get_parts($file, $bodyref->{id}, 'to_string');
if ($bodyref->{charset}) {
$tmp_body = iconv($tmp_body, $bodyref->{charset}, 'utf-8');
} else {
$tmp_body = iconv($tmp_body, $charset||$sjchar, 'utf-8');
}
}
$chst = $self->myiconv_setup($subj.$from.$oldto.$tmp_body.$nick);
}
$utf8->set_charset($sjchar) unless ($charset);
$tpl->assign(
CCSENT => $usercfg->{'ccsent'},
RTE_ON => $usercfg->{'compose_html'} ? 1 : 0,
BODY_IS_HTML => ($obody_type =~ /html/i?1:0),
);
my $type = ($usercfg->{'compose_html'} && $obody_type=~/html/i) ?
'text/html' : 'text/plain';
my $crlf = $type eq 'text/html' ? "</br>\n" : "\n";
open(my $NEW, "> .Drafts/tmp/$tmpdraft")
or die "Can't write to $tmpdraft";
print $NEW 'From: "'.rfc822_encode_str($chst,$self->myiconv($nick)).'"';
print $NEW " <".$ENV{USERNAME}.">\n";
print $NEW 'To: '.rfc822_encode_addr($chst, $self->myiconv($q->cgi('to')))."\n";
print $NEW 'Subject: '.rfc822_encode_str($chst,$self->myiconv('Fwd: '.$subj))."\n";
print $NEW 'Date: '.rfc822_date($self->userconfig->{'timezone'})."\n";
print $NEW "Mime-version: 1.0\n";
print $NEW "X-Originating-Ip: [$ENV{REMOTE_ADDR}]\n";
if(my $ver = $VERSION ? "ExtMail $VERSION" : '') {
print $NEW "X-Mailer: $ver\n";
}
$has_attach = 1 if (has_attach($file) ||
hdr_get_hash('Content-Disposition', %{$parts->{head}{hash}}) =~ /(attach|name)/i);
if($as_attach or defined $parts->{head}{hash}->{boundary} or $has_attach
or scalar @{$parts->{body}{list}} >1 ) { # XXX buggy, alternative part
# will have more parts!
$type = 'multipart/mixed';
}
print $NEW 'Content-Type: '.$type.'; ';
print $NEW "charset=\"$chst\";\n"; # XXX bug?
if($as_attach) {
$boundary = _gen_boundary(); # must new a boundary;
print $NEW " boundary=\"$boundary\"\n"; # more white space
}else {
if (hdr_get_hash('boundary', %{$parts->{head}{hash}})) {
# on normal forward mode, can use old boundary:)
$boundary = hdr_get_hash('boundary', %{$parts->{head}{hash}});
print $NEW " boundary=\"$boundary\"\n";
} elsif($has_attach) {
# XXX FIXME new state
$boundary = _gen_boundary();
print $NEW " boundary=\"$boundary\"\n";
} else {
print $NEW 'Content-Transfer-Encoding: 8bit'."\n";
}
}
print $NEW "\n"; # terminate header
if($as_attach) {
# Null body part XXX
my $type = $usercfg->{'compose_html'} ? 'text/html' : 'text/plain';
print $NEW "--$boundary\n";
print $NEW "Content-Type: $type; charset=\"$chst\";\n";
print $NEW "Content-Transfer-Encoding: 8bit\n\n";
print $NEW "\n"; # here wait for signature?
print $NEW $self->get_signature($type),"\n"; # must has newline
open(my $OLD, "< $file") or die "Can't open $file, $!\n";
print $NEW "--$boundary\n";
print $NEW "Content-Type: message/rfc822\n\n";
while(<$OLD>) {
print $NEW $_;
}
close $OLD;
print $NEW "\n";
print $NEW "--$boundary--\n";
}else {
if($boundary) { # has attach?
open(my $OLD, "< $file") or
die "Can't open $file, $!\n";
# build body
print $NEW "--$boundary\n";
# my $part0 = ${$parts->{body}{list}}[0]; # XXX
my $bodytype = ($usercfg->{'compose_html'} && $obody_type=~/html/i) ?
'text/html' : 'text/plain';
# convert encoding from old to new , must 8bit, currently only
# support text/plain, so 8bit is suitable
print $NEW "Content-Type: $bodytype; charset=\"$chst\";\n";
print $NEW "Content-Transfer-Encoding: 8bit\n\n";
print $NEW "\n";
my $body = '';
my $qtext = '';
print $NEW "$crlf-------- Forwarded Messages --------$crlf";
if ($obody_type =~ /html/i && $usercfg->{compose_html}) {
# the body is html and we enable compose_html
$from =~ s![<>]+!!g;
$oldto =~ s![<>]+!!g;
$from = txt2html($from, html_escape=>1);
$oldto = txt2html($oldto, html_escape=>1);
}
$qtext .= "From: $from $crlf";
$qtext .= "To: $oldto $crlf$crlf";
if ($obody_type =~ /html/i && !$usercfg->{compose_html}) {
$body = html2txt($body);
}
if ($bodyref->{id}>=0) {
$body = get_parts($file, $bodyref->{id}, 'to_string');
}
if ($bodyref->{charset}) {
# body has specific charset, we use it
$utf8->set_charset($bodyref->{charset});
}
$body = $utf8->utf8_encode($body);
$body = "$qtext\n$body";
$body = $self->html_quote($body) if ($obody_type =~ /html/i && $usercfg->{compose_html});
$body .= "\n".$self->get_signature($obody_type);
# it's time to do myiconv :)
$body = $self->myiconv($body);
print $NEW $body."\n";
# build attach part
my $cnt = 0;
foreach my $p (@{$parts->{body}{list}}) {
# XXX will ignore non-attachment part
if((!$p->{phead}->{filename} && !$p->{phead}->{name} &&
!$p->{phead}->{'Content-Disposition'} &&
$p->{phead}->{'Content-Disposition'} !~/attach/i) && $cnt<2) {
$cnt ++; # increase
next;
}
my ($a,$b) = ($p->{pos_start}, $p->{pos_end});
seek($OLD, $a, 0); # seek to the begin of part
print $NEW "--$boundary\n";
while(<$OLD>) {
print $NEW $_;
last if(tell $OLD>= $b);
}
$cnt++;
}
print $NEW "\n";
print $NEW "--$boundary--\n";
}else {
# no attach, normal body, we just want the normal body, part0
# my $part0 = ${$parts->{body}{list}}[0]; # XXX
open(my $OLD, "< $file") or
die "Can't open $file, $!\n";
my $body = '';
my $qtext = '';
if ($obody_type =~ /html/i && $usercfg->{compose_html}) {
# the body is html and we enable compose_html
$from =~ s![<>]+!!g;
$oldto =~ s![<>]+!!g;
$from = txt2html($from, html_escape=>1);
$oldto = txt2html($oldto, html_escape=>1);
}
print $NEW "$crlf-------- Forwarded Messages --------$crlf";
$qtext .= "From: $from $crlf";
$qtext .= "To: $oldto $crlf$crlf";
if ($bodyref->{id}>=0) {
$body = get_parts($file, $bodyref->{id}, 'to_string');
}
if ($obody_type =~ /html/i && !$usercfg->{compose_html}) {
$body = html2txt($body);
}
if ($bodyref->{charset}) {
# body has specific charset, we use it
$utf8->set_charset($bodyref->{charset});
}
$body = $utf8->utf8_encode($body);
$body = "$qtext\n$body";
$body = $self->html_quote($body) if ($obody_type =~ /html/i && $usercfg->{compose_html});
$body .= "\n".$self->get_signature($obody_type);
# it's time to do myiconv
$body = $self->myiconv($body);
print $NEW $body."\n";
}
}
close $NEW;
$self->myiconv_close;
my $newdraft = _gen_maildir_filename(".Drafts/tmp/$tmpdraft", '1');
rename(".Drafts/tmp/$tmpdraft", ".Drafts/tmp/$newdraft");
my $size = (stat '.Drafts/tmp/'.$newdraft)[7];
my $distname = "";
my ($is_oversize, $is_overquota);
my $errbuf = '';
if ($size > 0) {
if (my $sz = $self->is_oversize($size)) {
$is_oversize = 1;
$errbuf = sprintf($lang_compose{oversize}, human_size($sz));
} elsif (is_overquota($size, 1)>1) {
$is_overquota = 1;
$errbuf = $lang_compose{overquota};
}
}
if ($is_overquota || $is_oversize) {
$self->{_errmsg} = $errbuf;
$tpl->assign(OPMSG => $errbuf, ERRMSG => $errbuf);
unlink untaint(".Drafts/tmp/$newdraft");
return 0; # return on failure
}else {
$distname=$newdraft.",S=$size:2,S";
# XXX has performance problem FIXME
if (has_attach(".Drafts/tmp/$newdraft")) {
$distname .= 'A'; # if multipart, set flag to Attach
}
rename('.Drafts/tmp/'.$newdraft, '.Drafts/cur/'.$distname);
my @a = parse_curcnt('.Drafts');
$a[0] += $size; # if nagetive, perl will handle it:)
$a[1] ++;
open(FD, "> .Drafts/extmail-curcnt")
or die "Can't write to extmail-curcnt, $!\n";
flock(FD, LOCK_EX);
print FD "$a[0] $a[1] $a[2]\n";
flock(FD, LOCK_UN);
close FD;
my %quota = ();
$quota{a} = "$size 1";
update_quota_s(\%quota);
}
$self->show_draft($distname);
}
sub edit_reply {
my $self = shift;
my $q = $self->{query};
my $tpl = $self->{tpl};
my $folder = $q->cgi('folder') || 'Inbox';
my $pos = $q->cgi('pos') || 0;
my $file = _name2mdir($folder).'/cur/'.pos2file($folder, $pos);
my $parts = get_msg_info($file);
my $hdr = $parts->{head}{hash};
my $utf8 = Ext::Unicode->new;
my $charset = hdr_get_hash('Charset', %$hdr);
my $date = hdr_get_hash('Date', %$hdr);
my $from = decode_words_utf8(hdr_get_hash('From', %$hdr));
my $replyto = decode_words_utf8(hdr_get_hash('Reply-To', %$hdr));
my $return = decode_words_utf8(hdr_get_hash('Return-Path', %$hdr));
my ($to, $cc, $bcc) = (
decode_words_utf8(hdr_get_hash('To', %$hdr)),
decode_words_utf8(hdr_get_hash('Cc', %$hdr)),
decode_words_utf8(hdr_get_hash('Bcc', %$hdr)),
);
my $subj = decode_words_utf8(hdr_get_hash('Subject', %$hdr));
# XXX FIXME charset auto detect part
my $sjchar;
TRY: {
my $subject = decode_words(hdr_get_hash('Subject', %$hdr));
$subject =~ s/\s+//; # remove space
my $c = charset_detect($subject);
if ($c =~ /^(windows-1252|iso-8859-)/ && length $subject < 6) {
$sjchar = charset_detect(decode_words(hdr_get_hash('From', %$hdr)));
} else {
$sjchar = $c;
}
}
$from = iconv($from, $sjchar, 'utf-8') if charset_detect($from) ne 'utf-8';
$to = iconv($to, $sjchar, 'utf-8') if charset_detect($to) ne 'utf-8';
$cc = iconv($cc, $sjchar, 'utf-8') if charset_detect($cc) ne 'utf-8';
$bcc = iconv($bcc, $sjchar, 'utf-8') if charset_detect($bcc) ne 'utf-8';
$replyto = iconv($replyto, $sjchar, 'utf-8') if charset_detect($replyto) ne 'utf-8';
$return = iconv($replyto, $sjchar, 'utf-8') if charset_detect($return) ne 'utf-8';
$subj = iconv($subj, $sjchar, 'utf-8') if charset_detect($subj) ne 'utf-8';
# XXX FIXME set charset to subject charset if it's unavailable
$charset = $sjchar unless $charset;
my $pftype = $usercfg->{compose_html} ? 'text/html' : 'text/plain';
my $bodyref = _getbody($parts, $file, $pftype);
my $part0;
if ($pftype =~ /$bodyref->{type}/i) {
# yes we found the prefered type
$part0 = ${$parts->{body}{list}}[$bodyref->{id}]; # XXX
} else {
# oops, we fallback to the first part
$part0 = ${$parts->{body}{list}}[0];
}
$utf8->set_charset($bodyref->{charset} || $charset);
my $ctype = hdr_get_hash('Content-Type', %{$part0->{phead}}) || 'text/plain';
my $text = $utf8->utf8_encode($bodyref->{body});# the body text!
my $body_is_html = 0;
$date =~ s/\s*[-+]\d+\s*.*//;
my $quotetpl = $lang_compose{'quotetpl'} || '%s at %s wrote:';
if ($ctype =~ /html/i) {
$body_is_html = 1;
# format body text to reply style XXX to be fix
if (!$usercfg->{'compose_html'}) {
$text = html2txt($text);
$text =~ s#^(.{1})#>$1#;
$text =~ s#\n#\n>#g;
$text = sprintf("\n$quotetpl\n\%s", $from, $date, $text);
} else {
#$text =~ s!\r*\n!!gsi;
#$text =~ s!<\s*/?\s*br\s*/?\s*>!</br>\n!gsi;
#$text =~ s!</li>!</li>\n!gi;
#$text =~ s!</p>!</p>\r\n\r\n!gi;
#$text =~ s!</div>!\r\n!gi;
#$text =~ s!^(.{1})!>$1!;
#$text =~ s!\n!\n>!gsi;
# the following is waiting for fix, can't input under IE
# FIXME XXX the following code need to do subject auto focus()
# when everything loaded, but i don't know why, need help!
$text = $self->html_quote($text);
$text = sprintf("</br>\n$quotetpl\n\%s", $from, $date, $text);
}
} else {
$text =~ s#^(.{1})#>$1#;
$text =~ s#\n#\n>#g;
$text = sprintf("\n$quotetpl\n\%s", $from, $date, $text);
}
$tpl->assign(BODY_IS_HTML => $body_is_html);
# strip out RFC822 email addr, to be fix XXX FIXME
$from=~m{<*([^<> ]+@[^<> ]+)>*};
$from=$1;
$cc = $to . ($cc ? ", $cc" : '') if ($to);
if($q->cgi('replyall')) {
$tpl->assign(
CC => html_fmt($cc),
BCC => html_fmt($bcc)
);
}
$tpl->assign(
ORG_CHARSET => $charset,
CCSENT => $usercfg->{'ccsent'},
TO => html_fmt($replyto || $from || $return),
SUBJECT => html_fmt('Re: '.$subj),
BODY=>$text."\n\n". $self->get_signature($ctype),
RTE_ON => $usercfg->{'compose_html'},
);
}
sub edit_import {
my $self = shift;
my $q = $self->{query};
my $tpl = $self->{tpl};
my $itype = $q->cgi('type'); # import type
my %files;
my $nick = $usercfg->{'nick_name'} || rfc822_addr_parse($ENV{USERNAME})->{name};
if ($itype eq 'netdisk') {
my $base = url2str($q->cgi('base'));
my $a = $q->cgi_full_names;
my @arr = grep { /^FILE-/ } @$a;
if (@arr) {
for (@arr) {
my $file = url2str($q->cgi($_));
my $path = "./fileman/$base/$file";
my $size = (stat $path)[7];
$files{$file} = $path; # store it
}
}
}
return unless keys %files; # abort unless there is files
my $type = $usercfg->{compose_html} ? 'text/html' : 'text/plain';
# add the signature part
my $sig = $self->get_signature($type);
my $chst = $self->myiconv_setup($sig.$nick);
$nick = $self->myiconv($nick);
# XXX initialize
$tpl->assign(
CCSENT => $usercfg->{'ccsent'},
BODY => "\n\n". $sig,
RTE_ON => $self->userconfig->{compose_html} ? 1 : 0,
BODY_IS_HTML => $usercfg->{compose_html} ? 1: 0,
);
# XXX the following code derive from rebuild_attach()
my $tmpdraft = _gen_maildir_filename();
my $boundary = _gen_boundary();
open(my $FD, "> .Drafts/tmp/$tmpdraft")
or die "Can't write to $tmpdraft, $!\n";
select((select(FD), $| = 1)[0]);
print $FD 'From: "'.rfc822_encode_str($chst, $nick).'"';
print $FD " <".$ENV{USERNAME}.">\n";
print $FD 'To: '.rfc822_encode_addr($chst, $self->myiconv($q->cgi('to')))."\n";
print $FD 'Subject: '.rfc822_encode_str($chst, $self->myiconv($q->cgi('subject')))."\n";
print $FD 'Date: '.rfc822_date($self->userconfig->{'timezone'})."\n";
print $FD "Mime-version: 1.0\n";
print $FD "X-Originating-Ip: [$ENV{REMOTE_ADDR}]\n";
if(my $ver = $VERSION ? "ExtMail $VERSION" : '') {
print $FD "X-Mailer: $ver\n";
}
print $FD 'Content-Type: multipart/mixed; ';
print $FD "boundary=$boundary; charset=\"$chst\"\n";
print $FD 'Content-Transfer-Encoding: 8bit'."\n\n";
print $FD "This is a MIME-formatted message. If you see this text it means that your\n";
print $FD "mail software cannot handle MIME-formatted messages.\n\n";
print $FD "--$boundary\n";
print $FD "Content-Type: $type; charset=\"$chst\";\n";
print $FD "Content-Transfer-Encoding: 8bit\n\n";
$sig = $self->myiconv($sig);
print $FD "$sig\n"; # must prepend newline or I/O will fail
print $FD "\n";
# build the attachment parts
foreach my $f (keys %files) {
$chst = $self->myiconv_setup($f);
my $lf = $self->myiconv($f);
print $FD "--$boundary\n";
print $FD "Content-Disposition: attachment; filename=\"$lf\"\n";
print $FD "Content-Type: application/octet-stream; charset=\"$chst\"; name=\"$lf\"\n";
print $FD "Content-Transfer-Encoding: base64\n\n";
open (my $ATT, "< $files{$f}") or die "open $files{$f} fail, $!\n";
while(read($ATT, my $buf, 60*57)) {
print $FD encode_base64($buf);
}
close $ATT;
print $FD "\n"; # need?
}
print $FD "--$boundary--\n";
close $FD;
$self->myiconv_close;
# get the standard maildir name according to the official standard
# see http://cr.yp.to/maildir.html
my $newdraft = _gen_maildir_filename(".Drafts/tmp/$tmpdraft", '1');
rename(".Drafts/tmp/$tmpdraft", ".Drafts/tmp/$newdraft");
my $newsize = (stat '.Drafts/tmp/'.$newdraft)[7];
my $distname = $newdraft.",S=$newsize:2,SA"; # Attach flag
my $oldsize = 0;
# overquota or oversize (message) checks
my ($is_oversize, $is_overquota);
my $errbuf = '';
if ($newsize > 0) {
if (my $sz = $self->is_oversize($newsize)) {
$is_oversize = 1;
$errbuf = sprintf($lang_compose{oversize}, human_size($sz));
} elsif (is_overquota($newsize, 1)>1) {
$is_overquota = 1;
$errbuf = $lang_compose{overquota};
}
}
if ($is_overquota || $is_oversize) {
$self->{_errmsg} = $errbuf;
$tpl->assign(OPMSG => $errbuf, ERRMSG => $errbuf);
unlink untaint(".Drafts/tmp/$newdraft");
return 0; # return on failure
} else {
rename('.Drafts/tmp/'.$newdraft, '.Drafts/cur/'.$distname);
my @a = parse_curcnt('.Drafts');
# calculate the delta size
$a[0] += $newsize;
$a[1] ++; # new add situation
open(FD, "> .Drafts/extmail-curcnt")
or die "Can't write to extmail-curcnt, $!\n";
flock(FD, LOCK_EX);
print FD "$a[0] $a[1] $a[2]\n";
flock(FD, LOCK_UN);
close FD;
# Update system maildirsize file now
update_quota($newsize, 1);
}
my $newparts = get_msg_info('.Drafts/cur/'.$distname);
$self->show_attach('.Drafts/cur/'.$distname);
$tpl->assign(
'HAVE_DRAFT' => 1,
DRAFT => $distname,
OPMSG => $self->{opmsg},
);
1;
}
# attach_mgr() - manage attachment
sub attach_mgr {
my $self = shift;
my $q = $self->{query};
my $tpl = $self->{tpl};
my $draft = $q->cgi('draft') ? $q->cgi('draft') : ($tmp_draft ? $tmp_draft : undef);
$tpl->assign(
CCSENT => $usercfg->{'ccsent'},
RTE_ON => $usercfg->{'compose_html'},
);
if($q->cgi('doattach')) {
# XXX yes, upload now - by nick - FIXME, why append then remove?
$self->rebuild_attach('append');
return $self->rebuild_attach('remove');
}elsif($q->cgi('delete')) {
# XXX delete some attch
return $self->rebuild_attach('remove');
}elsif($q->cgi('return')) {
# XXX return to compose page
$self->edit_drafts;
return;
}elsif ($q->cgi('dosend') || $q->cgi('dosave')) {
return;
}else {
$self->error('No valid action taken');
}
reset_working_path();
$tpl->{template} = 'attachmgr.html';
}
sub show_attach {
my $self = shift;
$_[0]=~ m#([^\/]+)$#; # only name part, must match!
my $filename = maildir_find('.Drafts', $1); # try to find it
my $draft = '.Drafts/cur/'.$filename;
my $utf8 = Ext::Unicode->new;
my $tpl = $self->{tpl};
return unless($draft);
my $parts = get_msg_info($draft);
if(scalar @{$parts->{body}{list}} >1) {
$tpl->assign(LIST_ATTACH => 1);
my $cnt = 0;
my $files = get_parts_name($parts);
my $part;
foreach (1... scalar @$files-1) { # omit body
my $part = $files->[$_];
my $hdr = $part->{phead};
my $charset = hdr_get_hash('charset', %$hdr);
my $filename = decode_words_utf8($part->{name});
$utf8->set_charset($charset);
$tpl->assign(
'LOOP_ATTACH',
CNT => $cnt,
NAME => $charset ? $utf8->utf8_encode(decode_words($part->{name})) : $filename,
HSIZE => human_size($files->[$_]->{size})
);
$cnt ++;
}
}
}
sub show_draft {
my $self = shift;
my $draft = $_[0];
my $q = $self->{query};
my $tpl = $self->{tpl};
$draft = maildir_find('.Drafts', $draft); # try to find it
my($from,$to,$cc,$bcc,$subject,$body);
my $parts = get_msg_info('.Drafts/cur/'.$draft);
my $body_is_html = 0;
my $utf8 = Ext::Unicode->new;
$tpl->assign(
HAVE_DRAFT => 1,
DRAFT => $draft
);
my $part0 = ${$parts->{body}{list}}[0];
if($self->submited && !$q->cgi('return')) {
# XXX submited action, may be has attach or do/send etc.
$from = $q->cgi('from');
$to = $q->cgi('to');
$cc = $q->cgi('cc');
$bcc = $q->cgi('bcc');
$subject = $q->cgi('subject');
$body = $q->cgi('body');
}else {
# XXX call from Drafts folder messages list
# my $parts = get_msg_info('.Drafts/cur/'.$draft); XXX meaningless
my $hdr = $parts->{head}{hash};
my $pftype = $usercfg->{compose_html} ? 'text/html' : 'text/plain';
my $bodyref = _getbody($parts, ".Drafts/cur/$draft", $pftype);
my $charset = hdr_get_hash('charset', %$hdr);
$utf8->set_charset($bodyref->{charset} || $charset);
$from = $utf8->utf8_encode(decode_words(hdr_get_hash('From', %$hdr)));
$to = $utf8->utf8_encode(decode_words(hdr_get_hash('To', %$hdr)));
$cc = $utf8->utf8_encode(decode_words(hdr_get_hash('Cc', %$hdr)));
$bcc = $utf8->utf8_encode(decode_words(hdr_get_hash('Bcc', %$hdr)));
$subject = $utf8->utf8_encode(decode_words(hdr_get_hash('Subject', %$hdr)));
if ($pftype =~ /$bodyref->{type}/i) {
# yes we found the prefered type
$part0 = ${$parts->{body}{list}}[$bodyref->{id}]; # XXX
} # if not match, use the default setting above
$body = $utf8->utf8_encode($bodyref->{body});# the body text!
chomp $body; # XXX remove last \n added in rebuild
}
if ($part0->{phead}->{'Content-Type'} =~ /html/i or $q->cgi('html')) {
$body_is_html = 1;
# convert body to text if we are not in RTF mode
$body = html2txt($body) if !$usercfg->{compose_html};
}
$tpl->assign( BODY_IS_HTML => $body_is_html );
$tpl->assign(
FROM => $from,
TO => html_fmt($to),
CC => html_fmt($cc),
BCC => html_fmt($bcc),
SUBJECT => html_fmt($subject),
BODY => $body,
);
$self->show_attach('.Drafts/cur/'.$draft);
}
# rebuild_attach() - rebuild attachment parts, not include header
sub rebuild_attach {
my $self = shift;
my $mode = $_[0];
my $q = $self->{query};
my $tpl = $self->{tpl};
my $draft = $q->cgi('draft') ? $q->cgi('draft') : ($tmp_draft ? $tmp_draft : undef);
my $type = $q->cgi('html') ? 'text/html' : 'text/plain';
$draft = maildir_find('.Drafts', $draft); # try to find it
$self->{opmsg} = "Default information"; # operation message
my($newdraft) = ""; # function field varible
my($delta_size) = 0; # data size change(add/remove)
#$tpl->assign(SID => $q->cgi('sid')); # XXX must exists
if($draft) {# XXX already save or build draft
$tpl->assign(
'HAVE_DRAFT' => 1,
DRAFT => $draft
);
$newdraft = untaint(_gen_maildir_filename($draft));
# sucks, pass FD via object will cause more cleanup work,
# may be pass newdraft name is better? tobe fix
#
# remove $newdraft from tmp/ must be done whether we hit
# the bottom of rebuild_attach, so it's urgly implement:(
open($self->{newfd}, "> .Drafts/tmp/$newdraft") or
die "Can't write to $newdraft, $!\n";
if($mode eq 'append') {
unless($q->cgi('UPLOAD_FILES')) {
close $self->{newfd};
delete $self->{newfd};
unlink untaint(".Drafts/tmp/$newdraft");
return $draft;
# $self->show_attach('.Drafts/cur/'.$draft);
# return 1;
}
$self->rebuild_append_attach($draft);
}elsif($mode eq 'remove') {
my @a = grep { s/^REMOVE-// } @{$q->cgi_full_names};
unless(@a) {
close $self->{newfd};
delete $self->{newfd};
unlink untaint(".Drafts/tmp/$newdraft");
# $self->show_attach('.Drafts/cur/'.$draft);
return $draft;
}
$self->rebuild_remove_attach($draft);
}elsif($mode eq 'update') {
$self->rebuild_update_message($draft);
}else {
close $self->{newfd};
delete $self->{newfd};
unlink untaint(".Drafts/tmp/$newdraft");
$self->error('Unknow method: '. $mode);
return 0;
}
my $TMP = $self->{newfd};
if($self->{boundary}) {
print $TMP '--'.$self->{boundary}."--\n";
}
close $TMP;
}else {# XXX the first time, no $draft
$type = $q->cgi('html') ? 'text/html' : 'text/plain';
# The following code is deprecated, not need to gen newdraft
# here, from compose to attachmgr, newdraft will be create
# automatically
#
#if($q->cgi('doattach') or $q->cgi('dosave') or !$draft) {
# upload attach
# $newdraft = _gen_maildir_filename();
#}
#unless($draft) {
# new create if no draft
#}
my $tmpdraft = _gen_maildir_filename();
my $chst = $self->myiconv_setup;# $self->userconfig->{'charset'} || 'UTF-8';
my $nick = $self->myiconv($usercfg->{'nick_name'} || rfc822_addr_parse($ENV{USERNAME})->{name});
open(FD, "> .Drafts/tmp/$tmpdraft")
or die "Can't write to $tmpdraft, $!\n";
select((select(FD), $| = 1)[0]);
print FD 'From: "'.rfc822_encode_str($chst, $nick).'"';
print FD " <".$ENV{USERNAME}.">\n";
print FD 'To: '.rfc822_encode_addr($chst, $self->myiconv($q->cgi('to')))."\n";
if($q->cgi('cc')) {
print FD 'Cc: '.rfc822_encode_addr($chst, $self->myiconv($q->cgi('cc')))."\n";
}
if($q->cgi('bcc')) {
print FD 'Bcc: '.rfc822_encode_addr($chst, $self->myiconv($q->cgi('bcc')))."\n";
}
print FD 'Subject: '.rfc822_encode_str($chst, $self->myiconv($q->cgi('subject')))."\n";
print FD 'Date: '.rfc822_date($self->userconfig->{'timezone'})."\n";
print FD "Mime-version: 1.0\n";
print FD "X-Originating-Ip: [$ENV{REMOTE_ADDR}]\n";
if(my $ver = $VERSION ? "ExtMail $VERSION" : '') {
print FD "X-Mailer: $ver\n";
}
print FD 'Content-Type: '.$type.'; ';
print FD "charset=\"$chst\"\n";
print FD 'Content-Transfer-Encoding: 8bit'."\n";
print FD "\n";
print FD $self->myiconv(($q->cgi('html') ? $q->cgi('body') : $q->cgi('plaintext')||$q->cgi('body'))),"\n\n";
close FD;
# get the standard maildir name according to the official standard
# see http://cr.yp.to/maildir.html
$newdraft = _gen_maildir_filename(".Drafts/tmp/$tmpdraft", '1');
rename(".Drafts/tmp/$tmpdraft", ".Drafts/tmp/$newdraft");
$self->{opmsg} = $lang_compose{msgsaved} || 'Message Saved';
# XXX add by nick This var is for load attach_mgr() in draft_edit()
# Now we can add attach and save or send mail in one cgi request!
$tmp_draft = $newdraft.",S=".(stat '.Drafts/tmp/'.$newdraft)[7].":2,S";
}
# is_overquota part here should be redesign, the schema not clear!
my $newsize = (stat '.Drafts/tmp/'.$newdraft)[7];
my $distname = $newdraft.",S=$newsize:2,S";
my $oldsize = ( $draft ? (stat '.Drafts/cur/'.$draft)[7] : 0 );
$delta_size = ($newsize - $oldsize);
# XXX performance problem FIXME
if (has_attach(".Drafts/tmp/$newdraft")) {
$distname .= 'A'; # set Attach flag
}
# new mechanism, check delta whether it's >0 or not, if gt 0, we will
# check is_overquota, if lt 0, doest not need to check
my ($is_oversize, $is_overquota);
my $errbuf = '';
if ($delta_size > 0) {
if (my $sz = $self->is_oversize($newsize)) {
$is_oversize = 1;
$errbuf = sprintf($lang_compose{oversize}, human_size($sz));
} elsif (is_overquota($delta_size, $oldsize ? 0 : 1)>1) {
$is_overquota = 1;
$errbuf = $lang_compose{overquota};
}
}
if ($is_overquota || $is_oversize) {
$self->{_errmsg} = $errbuf;
$tpl->assign(OPMSG => $errbuf, ERRMSG => $errbuf);
unlink untaint(".Drafts/tmp/$newdraft");
return 0; # return on failure
} else {
# unlink '.Drafts/cur/'.$distname if (-r '.Drafts/cur/'.$distname);
rename(untaint(".Drafts/tmp/$newdraft"), untaint(".Drafts/cur/$distname"));
my @a = parse_curcnt('.Drafts');
# calculate the delta size
$a[0] += $delta_size; # if nagetive, perl will handle it:)
$a[1] ++ unless($draft); # add if new create
open(FD, "> .Drafts/extmail-curcnt")
or die "Can't write to extmail-curcnt, $!\n";
flock(FD, LOCK_EX);
print FD "$a[0] $a[1] $a[2]\n";
flock(FD, LOCK_UN);
close FD;
# Update system maildirsize file now
my %quota = ();
$quota{a} = "-$oldsize -1" if($draft);
$quota{b} = "$newsize 1";
update_quota_s(\%quota);
}
my $newparts = get_msg_info('.Drafts/cur/'.$distname);
# print Dumper($newparts);
# final clean up.., then curcnt timestamp newer than cache, so
# cache will be rebuild after return to the Drafts folder
# messages list :-( a bad trick?
unlink untaint(".Drafts/cur/$draft") if($draft ne $distname);
# XXX FIXME $self->show_attach('.Drafts/cur/'.$distname);
$tpl->assign(
'HAVE_DRAFT' => 1,
DRAFT => $distname,
OPMSG => $self->{opmsg}
);
delete $self->{opmsg}; # cleanup after usage
delete $self->{boundary};
delete $self->{newfd};
$distname;
}
sub rebuild_append_attach {
my $self = shift;
my $q = $self->{query};
my $draft = $_[0]; # already maildir_find() ?
my $type = 'multipart/mixed';
my $chst = $self->userconfig->{'charset'} || 'UTF-8';
unless($q->cgi('UPLOAD_FILES')) {
$self->{opmsg} = $lang_compose{noattupload} || 'No attch upload!';
return; # return if no attach, ouch
}
my $parts = get_msg_info('.Drafts/cur/'.$draft);
open(FD, "< .Drafts/cur/$draft") or die "Can't open $draft\n";
my $old = $/;
local $/ = "\n\n";
my $header = <FD>;
$/ = $old; # restore $/
unless($self->{boundary} = $parts->{head}{hash}->{boundary}) {
$self->{boundary} = _gen_boundary();
$header=~s#Content-Type: [^;]+;#Content-Type: $type;#;
$header=~s#charset="*([^\"]+)"*#charset="$1";\n boundary="$self->{boundary}"#;
$chst = $1 if $1;
$header=~s#Content-Transfer-encoding: \S+\n##; # remove this filed
}
my $TMP = $self->{newfd};
print $TMP $header;
print $TMP "This is a MIME-formatted message. If you see this text it means that your\n";
print $TMP "mail software cannot handle MIME-formatted messages.\n\n";
my $old_att_list = $parts->{body}{list};
foreach(0...scalar @$old_att_list -1) {
# print "this is the old $_ part</br>\n";
my $pos1 = $old_att_list->[$_]{pos_start};
my $pos2 = $old_att_list->[$_]{pos_end};
my $orig_type = $old_att_list->[$_]{phead}->{'Content-Type'};
my $orig_chst = $old_att_list->[$_]{phead}->{'charset'} || $chst;
if($orig_type =~/text/ and $_ eq 0) {
seek(FD, $pos1, 0);
my $old = $/;
local $/ = "\n\n";
<FD>; # remove head
$/ = $old;
print $TMP '--'.$self->{boundary}."\n";
print $TMP "Content-Type: $orig_type; charset=\"$orig_chst\";\n";
print $TMP "Content-Transfer-Encoding: 8bit\n\n";
while(<FD>) {
print $TMP $_;
last if(tell FD>=$pos2);
}
next;# next attach?
}
seek(FD, $pos1, 0); # seek to the begin, and ignore boundary
print $TMP "--$self->{boundary}\n";
while(<FD>) {
print $TMP $_;
last if(tell FD >= $pos2);
}
}
# insert the new attach into the newdraft
my $lists = $q->cgi('UPLOAD_FILES');
foreach(keys %$lists) {
# print "this is the new part $_</br>\n";
open(TFD, "< ".$lists->{$_}->{path})
or die "Attach open fail, $!\n";
my $old = $/;
local $/ = $CRLF.$CRLF;
my $hdr = <TFD>;
$hdr=~s/$CRLF/\n/g;
$/ = $old;
my %header = hdr_fmt_hash($hdr);
$header{filename} = _cvt2formal($header{filename});
($chst, $header{filename}) = $self->myiconv2($header{filename});
print $TMP "--$self->{boundary}\n";
print $TMP "Content-Disposition: attachment; filename=\"$header{filename}\"\n";
print $TMP 'Content-Type: '.$header{'Content-Type'}."; charset=\"$chst\"; name=\"$header{filename}\"\n";
print $TMP "Content-Transfer-Encoding: base64\n\n";
while(read(TFD, my $buf, 60*57)) {
print $TMP encode_base64($buf);
}
close TFD;
print $TMP "\n"; # need?
}
$self->{opmsg} = $lang_compose{attuploadok} || 'Attachment upload successfully';
}
sub rebuild_remove_attach {
my $self = shift;
my $q = $self->{query};
my $draft = $_[0];
my $type = $q->cgi('html') ? 'text/html' : 'text/plain';
my $parts = get_msg_info('.Drafts/cur/'.$draft);
$self->{boundary} = $parts->{head}{hash}->{boundary};
my $a = $q->cgi_full_names;
my @mimeid = grep { s/^REMOVE-// } @$a; # get mime id
open(FD, "< .Drafts/cur/$draft") or die "Can't open $draft\n";
my $old = $/;
local $/ = "\n\n";
my $header = <FD>;
$/ = $old; # restore $/
my $TMP = $self->{newfd};
print $TMP $header;
my $old_att_list = $parts->{body}{list};
foreach(0...scalar @$old_att_list -1) {
my $remove = 0;
foreach my $id (@mimeid) {
if($_ eq $id+1) {
$remove = 1;
last;
}
}
next if ($remove); # XXX
# print "this is the old $_ part</br>\n";
my $pos1 = $old_att_list->[$_]{pos_start};
my $pos2 = $old_att_list->[$_]{pos_end};
seek(FD, $pos1, 0);
print $TMP "--$self->{boundary}\n";
while(<FD>) {
print $TMP $_;
last if(tell FD >= $pos2);
}
}
$self->{opmsg} = $lang_compose{removeok};
}
sub rebuild_update_message {
my $self = shift;
my $q = $self->{query};
my $draft = $_[0];
my $type = $q->cgi('html') ? 'text/html' : 'text/plain';
my $parts = get_msg_info('.Drafts/cur/'.$draft);
my $chst = $self->myiconv_setup; # $self->userconfig->{'charset'} || 'UTF-8';
my $nick = $self->myiconv($usercfg->{'nick_name'} || rfc822_addr_parse($ENV{USERNAME})->{name});
if(scalar @{$parts->{body}{list}}>0 && $parts->{head}{hash}->{boundary}) {
$type = 'multipart/mixed';
}
open(FD, "< .Drafts/cur/$draft") or die "dam ..$!\n";
$self->{boundary} = $parts->{head}{hash}->{boundary}; # may be undef
my $TMP = $self->{newfd};
print $TMP 'From: "'.rfc822_encode_str($chst,$nick).'"';
print $TMP " <".$ENV{USERNAME}.">\n";
print $TMP 'To: '.rfc822_encode_addr($chst,$self->myiconv($q->cgi('to')))."\n";
if($q->cgi('cc')) {
print $TMP 'Cc: '.rfc822_encode_addr($chst,$self->myiconv($q->cgi('cc')))."\n";
}
if($q->cgi('bcc')) {
print $TMP 'Bcc: '.rfc822_encode_addr($chst,$self->myiconv($q->cgi('bcc')))."\n";
}
print $TMP 'Subject: '.rfc822_encode_str($chst,$self->myiconv($q->cgi('subject')))."\n";
print $TMP 'Date: '.rfc822_date($self->userconfig->{'timezone'})."\n";
print $TMP "Mime-version: 1.0\n";
print $TMP "X-Originating-Ip: [$ENV{REMOTE_ADDR}]\n";
if(my $ver = $VERSION ? "ExtMail $VERSION" : '') {
print $TMP "X-Mailer: $ver\n";
}
print $TMP 'Content-Type: '.$type.'; ';
if($self->{boundary}) {
print $TMP 'boundary="'.$self->{boundary}.'";'."\n";
print $TMP " charset=$chst\n\n";
print $TMP "This is a MIME-formatted message. If you see this text it means that your\n";
print $TMP "mail software cannot handle MIME-formatted messages.\n";
}else {
print $TMP "charset=\"$chst\"\n";
print $TMP 'Content-Transfer-Encoding: 8bit'."\n";
}
print $TMP "\n";
if($self->{boundary}) {
# restore the original content-type ? No, now extmail can
# support html/plain mail, so check html flag
my $body_type = $q->cgi('html') ? 'text/html' : 'text/plain';
print $TMP "--$self->{boundary}\n";
print $TMP "Content-Type: $body_type; charset=\"$chst\"\n";
print $TMP "Content-Transfer-Encoding: 8bit\n\n";
}
print $TMP $self->myiconv(($q->cgi('html')? $q->cgi('body'): $q->cgi('plaintext')||$q->cgi('body'))), "\n";
if($self->{boundary}) {
my $old_att_list = $parts->{body}{list};
foreach(1...scalar @$old_att_list -1) {
# print "this is the old $_ part</br>\n";
my $pos1 = $old_att_list->[$_]{pos_start};
my $pos2 = $old_att_list->[$_]{pos_end};
my $orig_type = $old_att_list->[$_]{phead}->{'Content-Type'};
my $orig_chst = $old_att_list->[$_]{phead}->{'charset'};
if($orig_type =~/text/ and $_ eq 0) {
seek(FD, $pos1, 0);
my $old = $/;
local $/ = "\n\n";
<FD>; # remove head
$/ = $old;
print $TMP "--$self->{boundary}\n";
print $TMP "Content-Type: $orig_type; charset=\"$orig_chst\";\n";
print $TMP "Content-Transfer-Encoding: 8bit\n\n";
while(<FD>) {
print $TMP $_;
last if(tell FD>=$pos2);
}
next;# next attach?
}
seek(FD, $pos1, 0); # seek to the begin, and ignore boundary
print $TMP "--$self->{boundary}\n";
while(<FD>) {
print $TMP $_;
last if(tell FD >= $pos2);
}
}
}
$self->{opmsg} = $lang_compose{msgupdated} || 'Message updated';
$self->{opmsg} = $lang_compose{draftsaved} || 'Draft saved' if($q->cgi('dosave')); # XXX
}
sub sendmail {
my $self = shift;
my $q = $self->{query};
my $file = $_[0];
my $from = $ENV{USERNAME} || 'extmail@localhost';
my $opmsg = 'Message Send fail!';
my $sendmail = "/usr/sbin/sendmail -oi -t -f \"$from\"";
my $errbuf = ''; # initialize
local $ENV{PATH} = '';
open(CMD, "|$sendmail") or die "sendmail command error: $!\n";
open(FD, "< .Drafts/cur/".$file) or die "Can't open $file, $!\n";
# line by line, slow but simple method
while(<FD>) {
print CMD $_;
}
close FD;
close CMD or $errbuf = "Send fail, return code $?\n";
if ($errbuf) {
$errbuf =~ s#\n#</br>\n#g;
die "$errbuf";
}
$opmsg = $lang_compose{msgsent} || 'Message Sent!';
# update curcnt cache and reflect to maildirsize, must do it
my @a = parse_curcnt('.Drafts');
my @b = parse_curcnt('.Sent');
# bugfix: use $q->cgi('ccsent') only, don't check user.cf
my $fcc = $q->cgi('ccsent') || 0;
# calculate the delta size
my $dsize = (stat '.Drafts/cur/'.$file)[7];
$a[0]-=$dsize;
$a[1]-=1;
$b[0]+=$dsize;
$b[1]+=1;
if($fcc) {
rename(untaint(".Drafts/cur/$file"), untaint(".Sent/cur/$file")); # move
open(FD, "> .Sent/extmail-curcnt")
or die "Can't write to extmail-curcnt, $!\n";
flock(FD, LOCK_EX);
print FD "$b[0] $b[1] $b[2]\n";
flock(FD, LOCK_UN);
close FD;
if(has_attach('.Sent/cur/'.$file)) {
my $tf = "";
if($file=~!/:2,.*A.*/) {# not flag
$file=~/([^\:]+):2,(.*)/;
$tf = $1.':2,A'.$2;
}
rename(untaint(".Sent/cur/$file"), untaint(".Sent/cur/$tf"));
}
$opmsg .= $lang_compose{fccdone} || ' FCC to Sent done!';
}else {
unlink untaint(".Drafts/cur/$file"); # delete it
my %quota = ();
$quota{a} = "-$dsize -1";
update_quota_s(\%quota);
}
open(FD, "> .Drafts/extmail-curcnt")
or die "Can't write to extmail-curcnt, $!\n";
flock(FD, LOCK_EX);
print FD "$a[0] $a[1] $a[2]\n";
flock(FD, LOCK_UN);
close FD;
# do the cc/bcc/to auto save to abook
if ($usercfg->{addr2abook}) {
my $to = $q->cgi('to');
my $cc = $q->cgi('cc');
my $bcc = $q->cgi('bcc');
my $obj = Ext::Abook->new(file=>'abook.cf');
my $abook = $obj->dump;
my $save = 0;
my @addr2save;
for my $v ($to,$cc,$bcc) {
my @ar = split(/\s*,\s*/, $v);
for my $m (@ar) {
my $ref = rfc822_addr_parse($m);
my $match = 0;
for(my $k=1;$k<scalar @$abook; $k++) {
my $e = $abook->[$k];
if (lc $ref->{addr} eq lc $e->[1]) {# addr match?
$match = 1;
last;
}
}
next if $match;
$obj->append([$ref->{name},$ref->{addr},'','']);
$save ||= 1;
push @addr2save, $ref->{addr};
}
# end of loop, do we need to call save?
}
if ($save) {
for (@addr2save) {
$self->{tpl}->assign(
'ADDR2SAVE',
ADDR => $_,
);
}
$obj->save;
}
}
$self->{tpl}->assign( OPMSG => $opmsg);
}
sub submited {
my $self = shift;
my $q = $self->{query};
return 0 unless($q->cgi('doattach') or $q->cgi('dosave')
or $q->cgi('dosend') or $q->cgi('attachmgr'));
1;
}
#--------------------------------------------------------------------#
# utility function defined below #
#--------------------------------------------------------------------#
sub _gen_boundary {
return sprintf "=_%s_%s_%s", int(rand(100)), $$, time;
}
sub _gen_maildir_filename {
# according to http://cr.yp.to/proto/maildir.html and compatible
# with sqwebmail or maildrop etc, include postfix
my ($oldname, $flag) = @_;
if($oldname && $flag) { # get the standard maildir name
return gen_std_maildir($oldname);
}elsif($oldname) { # only strip status information
$oldname=~ s#([^,]+),S=.*#$1#;
return $oldname;
}else { # return the initial filename
return sprintf "%s_P%s_%s", time, $$, 'extmail';
}
}
sub _gen_name_tpart {
eval {
require 'sys/syscall.ph';
};
if($@) { return time; }
return time unless (defined &SYS_gettimeofday);
my $start = pack('LL', ());
syscall(&SYS_gettimeofday, $start, 0) != -1
or die "gettimeofday: $!";
my @start = unpack('LL', $start);
$start[0].'.M'.$start[1];
}
sub _cvt2formal {
my $filename = shift;
if($filename=~/\\/) { # win32 filename, eg: c:\\doc\\test.gif
$filename=~ s#.*\\+([^\\]+)$#$1#;
}elsif($filename=~/\//) { # Unix path name, eg: /path/to/test.gif
$filename=~ s#.*\/+([^\/]+)$#$1#;
}else {
$filename=~ s#\s##g; # remove all space
}
$filename
}
sub _getsizes {
my $file = shift;
return (stat $file)[7];
}
sub _getbody {
my $parts = shift; # the parsed strcture
my $file = shift; # the maildir file
my $pftype = shift || 'plain'; # prefer body type
my $body = '';
$pftype =~ s!text/!!;
my @arr = @{get_parts_name($parts)}; # generate part
if (scalar @arr >1 && $arr[0]->{idflag} =~/alternative/i &&
$arr[0]->{idflag} eq $arr[1]->{idflag}) {
# we found something alternative
for (my $i=0;$i<2;$i++) {
my $ctype = hdr_get_hash('Content-Type', %{$arr[$i]->{phead}});
my $char = hdr_get_hash('charset', %{$arr[$i]->{phead}});
next if $ctype !~ /$pftype/i;
$body = get_parts($file, $i, 'to_string');
if ($ctype =~/html/i) {
$body = htmlsanity($body);
}
return {
body => $body,
type => $ctype,
id => $i,
charset => $char,
};
}
} else {
my $ctype = hdr_get_hash('Content-Type', %{$arr[0]->{phead}});
my $char = hdr_get_hash('charset', %{$arr[0]->{phead}});
if ($ctype !~ /text/i) {
return {
body => '',
charset => $char,
type => "text/$pftype",
id => -1,
};
}
$body = get_parts($file, 0, 'to_string');
if ($ctype =~ /html/i) {
$body = htmlsanity($body);
}
return {
body => $body,
type => $ctype,
charset => $char,
id => 0,
};
}
}
sub is_oversize {
my $self = shift;
my $sys = $self->{sysconfig};
my $maxsize = $sys->{SYS_MESSAGE_SIZE_LIMIT};
my $tsize = shift;
return 0 unless defined $maxsize and $maxsize > 0;
return 0 unless defined $tsize and $tsize > 0;
if ($tsize >= $maxsize) {
return $maxsize;
}
0;
}
sub get_signature {
my $self = shift;
my $ctype = shift;
my $htmlize = 0;
my $buf;
# bug XXX FIXME
if (defined $ctype) {
if ($ctype =~ /html/ && $usercfg->{compose_html}) {
$htmlize = 1;
}
} elsif ($usercfg->{compose_html}) {
$htmlize = 1;
}
return "" unless (-r 'signature.cf'); # current directory
open (FD, "< signature.cf"); # ignore error
while (<FD>) {
if ($htmlize) {
s#<#< #g;
s#># >#g;
s#"# " #g;
s#\n#</br>\n#g;
}
$buf .= $_;
}
$buf = txt2link($buf) if ($htmlize);
if ($htmlize) {
$buf = "<br>\n<br>\n$buf";
} else {
$buf = "\n\n$buf";
}
$buf;
}
sub html_quote {
my $self = shift;
my $text = shift; # text to quote?
my $quote_start = $lang_compose{'div_quote_start'} ||
'</br><div><blockquote style="border-left: 1px solid '.
'rgb(204, 204, 204); margin: 0pt 0pt 0pt 0.8ex; '.
'padding-left: 1ex;">';
my $quote_end = $lang_compose{'div_quote_end'} ||
'</blockquote></div></br>';
$text = "</br>\n$quote_start\n".
"$text\n".
"$quote_end\n";
$text;
}
sub myiconv_setup {
my $self = shift;
my $buf = shift;
my $lang = $usercfg->{lang};
my $need_local = $usercfg->{trylocal};
my $q = $self->{query};
if (!$need_local) {
$self->{_prefer_charset} = 'UTF-8';
return 'UTF-8';
}
if (!$buf) {
$buf .= $q->cgi('to').$q->cgi('cc').$q->cgi('bcc');
$buf .= ($q->cgi('body') || $q->cgi('plaintext'));
$buf .= $usercfg->{'nick_name'} . $q->cgi('subject');
}
# supported local encoding maps, return null if not supported
my $intl = intl2euc($lang);
if (!$buf and $intl and $need_local) {
$self->{_prefer_charset} = $intl;
return $intl;
}
# XXX FIXME dont' turun on perl tain mode perl -wT, or it
# will break the width char regexp !!
my $rv = Encode::PPUniDetector::trylocal2($buf, $intl);
if ($rv) {
$self->{_prefer_charset} = $rv;
} else {
$self->{_prefer_charset} = 'UTF-8';
}
return $self->{_prefer_charset};
}
# intergrated with setup and conv and close .hehe~
sub myiconv2 {
my $self = shift;
my $buf = shift;
my $prefer_euc = intl2euc($usercfg->{lang});
return ('UTF-8', $buf) unless $buf;
my $rv = Encode::PPUniDetector::trylocal2($buf, $prefer_euc);
if ($rv && uc $rv ne 'UTF-8') {
$buf = iconv($buf, 'utf-8', $rv);
}
return ($rv||'UTF-8', $buf);
}
sub myiconv {
my $self = shift;
my $str = shift;
if (uc $self->{_prefer_charset} ne 'UTF-8') {
# need to convert
$str = iconv($str, 'utf-8', $self->{_prefer_charset});
}
# return string
return $str;
}
sub myiconv_close {
my $self = shift;
delete $self->{_prefer_charset};
}
sub pre_run { 1 }
sub post_run {
my $self = shift;
my $q = $self->{query};
my $tpl = $self->{tpl};
# dirty hack, to fallback original working path, ouch :-(
unless($tpl->{noprint}) {
my $template = $q->cgi('screen') || $tpl->{template} || 'compose.html';
reset_working_path();
$tpl->process($template);
$tpl->print;
}
}
sub DESTORY {
}
1;
syntax highlighted by Code2HTML, v. 0.9.1