2 # Functions to parsing user mail files
5 if ($userconfig{'date_tz'} || $config{'date_tz'}) {
6 # Set the timezone for all date calculations, and force a conversion
7 # now as in some cases the first one fails!
8 $ENV{'TZ'} = $userconfig{'date_tz'} ||
10 strftime('%H:%M', localtime(time()));
14 $dbm_index_min = 1000000;
15 $dbm_index_version = 3;
17 # list_mails(user|file, [start], [end])
18 # Returns a subset of mail from a mbox format file
21 local (@rv, $h, $done);
23 &build_dbm_index($_[0], \%index);
25 local $isize = $index{'mailcount'};
26 if (@_ == 1 || !defined($_[1]) && !defined($_[2])) {
27 $start = 0; $end = $isize-1;
30 $start = $isize+$_[2]-1; $end = $isize+$_[1]-1;
31 $start = $start<0 ? 0 : $start;
34 $start = $_[1]; $end = $_[2];
35 $end = $isize-1 if ($end >= $isize);
37 $rv[$isize-1] = undef if ($isize); # force array to right size
38 local $dash = &dash_mode($_[0]);
39 open(MAIL, &user_mail_file($_[0]));
40 $start = 0 if ($start < 0);
41 for($i=$start; $i<=$end; $i++) {
42 # Seek to mail position
43 local @idx = split(/\0/, $index{$i});
45 local $startline = $idx[1];
49 local $mail = &read_mail_fh(MAIL, $dash ? 2 : 1, 0);
50 $mail->{'line'} = $startline;
51 $mail->{'eline'} = $startline + $mail->{'lines'} - 1;
53 # ID is position in file and message ID
54 $mail->{'id'} = $pos." ".$i." ".$startline." ".
55 substr($mail->{'header'}->{'message-id'}, 0, 255);
61 # select_mails(user|file, &ids, headersonly)
62 # Returns a list of messages from an mbox with the given IDs. The ID contains
63 # the file offset, message number, line and message ID, and the former is used
67 local ($file, $ids, $headersonly) = @_;
74 local $umf = &user_mail_file($file);
75 local $dash = &dash_mode($umf);
77 foreach my $i (@$ids) {
78 local ($pos, $idx, $startline, $wantmid) = split(/ /, $i);
80 # Go to where the mail is supposed to be, and check if any starts there
83 local $fromok = $ll !~ /^From\s+(\S+).*\d+\r?\n/ ||
84 ($1 eq '-' && !$dash) ? 0 : 1;
85 print DEBUG "seeking to $pos in $umf, got $ll";
87 # Oh noes! Need to find it
89 &build_dbm_index($file, \%index);
92 while(my ($k, $v) = each %index) {
94 my ($p, $line, $subject, $from, $mid)=
96 if ($mid eq $wantmid) {
110 local $mail = &read_mail_fh(MAIL, $dash ? 2 : 1, $headersonly);
111 $mail->{'line'} = $startline;
112 $mail->{'eline'} = $startline + $mail->{'lines'} - 1;
113 $mail->{'idx'} = $idx;
114 $mail->{'id'} = "$pos $idx $startline $wantmid";
118 push(@rv, undef); # Mail is gone?
125 # idlist_mails(user|file)
126 # Returns a list of IDs in some mbox
130 local $idlist = &build_dbm_index($_[0], \%index);
134 # search_mail(user, field, match)
135 # Returns an array of messages matching some search
138 return &advanced_search_mail($_[0], [ [ $_[1], $_[2] ] ], 1);
141 # advanced_search_mail(user|file, &fields, andmode, [&limits], [headersonly])
142 # Returns an array of messages matching some search
143 sub advanced_search_mail
145 local (%index, @rv, $i);
146 local $dash = &dash_mode($_[0]);
147 local @possible; # index positions of possible mails
148 local $possible_certain = 0; # is possible list authoratative?
151 # We have a DBM index .. if the search includes the from and subject
152 # fields, scan it first to cut down on the total time
153 &build_dbm_index($_[0], \%index);
155 # Check which fields are used in search
156 local @dbmfields = grep { $_->[0] eq 'from' ||
157 $_->[0] eq 'subject' } @{$_[1]};
158 local $alldbm = (scalar(@dbmfields) == scalar(@{$_[1]}));
161 $max = $index{'mailcount'}-1;
162 if ($_[3] && $_[3]->{'latest'}) {
163 $min = $max - $_[3]->{'latest'};
166 # Only check DBM if it contains some fields, and if it contains all
167 # fields when in 'or' mode.
168 if (@dbmfields && ($alldbm || $_[2])) {
169 # Scan the DBM to build up a list of 'possibles'
170 for($i=$min; $i<=$max; $i++) {
171 local @idx = split(/\0/, $index{$i});
172 local $fake = { 'header' => { 'from', $idx[2],
173 'subject', $idx[3] } };
174 local $m = &mail_matches(\@dbmfields, $_[2], $fake);
175 push(@possible, $i) if ($m);
177 $possible_certain = $alldbm;
180 # None of the DBM fields are in the search .. have to scan all
181 @possible = ($min .. $max);
184 # Need to scan through possible messages to find those that match
185 open(MAIL, &user_mail_file($_[0]));
186 local $headersonly = !&matches_needs_body($_[1]);
187 foreach $i (@possible) {
188 # Seek to mail position
189 local @idx = split(/\0/, $index{$i});
190 local $pos = $idx[0];
191 local $startline = $idx[1];
195 local $mail = &read_mail_fh(MAIL, $dash ? 2 : 1, $headersonly);
196 $mail->{'line'} = $startline;
197 $mail->{'eline'} = $startline + $mail->{'lines'} - 1;
199 $mail->{'id'} = $pos." ".$i." ".$startline." ".
200 substr($mail->{'header'}->{'message-id'}, 0, 255);
201 push(@rv, $mail) if ($possible_certain ||
202 &mail_matches($_[1], $_[2], $mail));
207 # build_dbm_index(user|file, &index)
208 # Updates a reference to a DBM hash that indexes the given mail file.
209 # Hash contains keys 0, 1, 2 .. each of which has a value containing the
210 # position of the mail in the file, line number, subject, sender and message ID.
211 # Special key lastchange = time index was last updated
212 # mailcount = number of messages in index
213 # version = index format version
214 # Returns a list of all IDs
217 local $ifile = &user_index_file($_[0]);
218 local $umf = &user_mail_file($_[0]);
219 local @st = stat($umf);
220 local $index = $_[1];
221 dbmopen(%$index, $ifile, 0600);
224 local $idsfile = $ifile.".ids";
227 if (open(IDSFILE, $idsfile)) {
233 if (scalar(@ids) != $index->{'mailcount'}) {
234 # Build for first time
235 print DEBUG "need meta-index rebuild for $_[0] ",scalar(@ids)," != ",$index->{'mailcount'},"\n";
237 while(my ($k, $v) = each %$index) {
238 if ($k eq int($k) && $k < $index->{'mailcount'}) {
239 local ($pos, $line, $subject, $sender, $mid) =
241 $ids[$k] = $pos." ".$k." ".$line." ".$mid;
243 elsif ($k >= $index->{'mailcount'}) {
244 # Old crap that is off the end
245 delete($index->{$k});
248 $index->{'mailcount'} = scalar(@ids); # Now known for sure
253 $index->{'lastchange'} < $st[9] ||
254 $index->{'lastsize'} != $st[7] ||
255 $st[7] < $dbm_index_min ||
256 $index->{'version'} != $dbm_index_version) {
257 # The mail file is newer than the index, or we are always re-indexing
260 local $dash = &dash_mode($umf);
261 if ($st[7] < $dbm_index_min ||
262 $index->{'version'} != $dbm_index_version) {
263 $fromok = 0; # Always re-index
267 if (open(MAIL, $umf)) {
268 # Check the last 100 messages (at most), to see if
269 # the mail file has been truncated, had mails deleted,
271 local $il = $index->{'mailcount'}-1;
273 for($i=($il>100 ? 100 : $il); $i>=0; $i--) {
274 @idx = split(/\0/, $index->{$il-$i});
275 seek(MAIL, $idx[0], 0);
277 $fromok = 0 if ($ll !~ /^From\s+(\S+).*\d+\r?\n/ ||
278 ($1 eq '-' && !$dash));
282 $fromok = 0; # No mail file yet
285 local ($pos, $lnum, $istart);
286 if ($index->{'mailcount'} && $fromok && $st[7] > $idx[0]) {
287 # Mail file seems to have gotten bigger, most likely
288 # because new mail has arrived ... only reindex the new mails
289 print DEBUG "re-indexing from $idx[0]\n";
290 $pos = $idx[0] + length($ll);
292 $istart = $index->{'mailcount'};
295 # Mail file has changed in some other way ... do a rebuild
297 print DEBUG "totally re-indexing\n";
306 local ($doingheaders, @nidx);
308 if (/^From\s+(\S+).*\d+\r?\n/ && ($1 ne '-' || $dash)) {
309 @nidx = ( $pos, $lnum );
311 push(@ids, $pos." ".$istart." ".$lnum);
312 $index->{$istart++} = join("\0", @nidx);
315 elsif ($_ eq "\n" || $_ eq "\r\n") {
318 elsif ($doingheaders && /^From:\s*(.{0,255})/i) {
320 $index->{$istart-1} = join("\0", @nidx);
322 elsif ($doingheaders && /^Subject:\s*(.{0,255})/i) {
324 $index->{$istart-1} = join("\0", @nidx);
326 elsif ($doingheaders && /^Message-ID:\s*(.{0,255})/i) {
328 $index->{$istart-1} = join("\0", @nidx);
329 $ids[$#ids] .= " ".$1;
335 $index->{'lastchange'} = time();
336 $index->{'lastsize'} = $st[7];
337 $index->{'mailcount'} = $istart;
338 $index->{'version'} = $dbm_index_version;
341 # Write out IDs file, if needed
343 open(IDSFILE, ">$idsfile");
344 foreach my $id (@ids) {
345 print IDSFILE $id,"\n";
353 # has_dbm_index(user|file)
354 # Returns 1 if a DBM index exists for some user or file
357 local $ifile = &user_index_file($_[0]);
358 foreach my $ext (".dir", ".pag", ".db") {
359 return 1 if (-r $ifile.$ext);
364 # empty_mail(user|file)
365 # Truncate a mail file to nothing
368 local $umf = &user_mail_file($_[0]);
369 local $ifile = &user_index_file($_[0]);
370 open(TRUNC, ">$umf");
373 # Set index size to 0
375 dbmopen(%index, $ifile, 0600);
376 $index{'mailcount'} = 0;
377 $index{'lastchange'} = time();
381 # count_mail(user|file)
382 # Returns the number of messages in some mail file
386 &build_dbm_index($_[0], \%index);
387 return $index{'mailcount'};
390 # parse_mail(&mail, [&parent], [savebody], [keep-cr])
391 # Extracts the attachments from the mail body
394 return if ($_[0]->{'parsed'}++);
395 local $ct = $_[0]->{'header'}->{'content-type'};
396 local (@attach, $h, $a);
397 if ($ct =~ /multipart\/(\S+)/i && ($ct =~ /boundary="([^"]+)"/i ||
398 $ct =~ /boundary=([^;\s]+)/i)) {
399 # Multipart MIME message
400 local $bound = "--".$1;
401 local @lines = $_[3] ? split(/\n/, $_[0]->{'body'})
402 : split(/\r?\n/, $_[0]->{'body'});
405 while($l < $max && $lines[$l++] ne $bound) {
406 # skip to first boundary
409 # read attachment headers
410 local (@headers, $attach);
412 $attach->{'raw'} .= $lines[$l]."\n";
413 $attach->{'rawheaders'} .= $lines[$l]."\n";
414 if ($lines[$l] =~ /^(\S+):\s*(.*)/) {
415 push(@headers, [ $1, $2 ]);
417 elsif ($lines[$l] =~ /^\s+(.*)/) {
418 $headers[$#headers]->[1] .= " ".$1
419 unless($#headers < 0);
423 $attach->{'raw'} .= $lines[$l]."\n";
425 $attach->{'headers'} = \@headers;
426 foreach $h (@headers) {
427 $attach->{'header'}->{lc($h->[0])} = $h->[1];
429 if ($attach->{'header'}->{'content-type'} =~ /^([^;\s]+)/) {
430 $attach->{'type'} = lc($1);
433 $attach->{'type'} = 'text/plain';
435 if ($attach->{'header'}->{'content-disposition'} =~
436 /filename\s*=\s*"([^"]+)"/i) {
437 $attach->{'filename'} = $1;
439 elsif ($attach->{'header'}->{'content-disposition'} =~
440 /filename\s*=\s*([^;\s]+)/i) {
441 $attach->{'filename'} = $1;
443 elsif ($attach->{'header'}->{'content-type'} =~
444 /name\s*=\s*"([^"]+)"/i) {
445 $attach->{'filename'} = $1;
447 elsif ($attach->{'header'}->{'content-type'} =~
448 /name\s*=\s*([^;\s]+)/i) {
449 $attach->{'filename'} = $1;
452 # read the attachment body
453 while($l < $max && $lines[$l] ne $bound && $lines[$l] ne "$bound--") {
454 $attach->{'data'} .= $lines[$l]."\n";
455 $attach->{'raw'} .= $lines[$l]."\n";
458 $attach->{'data'} =~ s/\n\n$/\n/; # Lose trailing blank line
459 $attach->{'raw'} =~ s/\n\n$/\n/;
461 # decode if necessary
462 if (lc($attach->{'header'}->{'content-transfer-encoding'}) eq
464 # Standard base64 encoded attachment
465 $attach->{'data'} = &b64decode($attach->{'data'});
467 elsif (lc($attach->{'header'}->{'content-transfer-encoding'}) eq
469 # UUencoded attachment
470 $attach->{'data'} = &uudecode($attach->{'data'});
472 elsif (lc($attach->{'header'}->{'content-transfer-encoding'}) eq
473 'quoted-printable') {
474 # Quoted-printable text attachment
475 $attach->{'data'} = "ed_decode($attach->{'data'});
477 elsif (lc($attach->{'type'}) eq 'application/mac-binhex40' && &has_command("hexbin")) {
478 # Macintosh binhex encoded attachment
479 local $temp = &transname();
481 open(HEXBIN, "| (cd $temp ; hexbin -n attach -d 2>/dev/null)");
482 print HEXBIN $attach->{'data'};
485 open(HEXBIN, "$temp/attach.data");
487 $attach->{'data'} = <HEXBIN>;
489 local $ct = &guess_mime_type($attach->{'filename'});
490 $attach->{'type'} = $ct;
491 $attach->{'header'} = { 'content-type' => $ct };
492 $attach->{'headers'} = [ [ 'Content-Type', $ct ] ];
494 unlink("$temp/attach.data");
498 $attach->{'idx'} = scalar(@attach);
499 $attach->{'parent'} = $_[1] ? $_[1] : $_[0];
500 push(@attach, $attach) if (@headers || $attach->{'data'});
501 if ($attach->{'type'} =~ /multipart\/(\S+)/i) {
502 # This attachment contains more attachments ..
504 local $amail = { 'header' => $attach->{'header'},
505 'body' => $attach->{'data'} };
506 &parse_mail($amail, $attach, 0, $_[3]);
507 $attach->{'attach'} = [ @{$amail->{'attach'}} ];
508 map { $_->{'idx'} += scalar(@attach) }
509 @{$amail->{'attach'}};
510 push(@attach, @{$amail->{'attach'}});
512 elsif (lc($attach->{'type'}) eq 'application/ms-tnef') {
513 # This attachment is a winmail.dat file, which may
514 # contain multiple other attachments!
515 local ($opentnef, $tnef);
516 if (!($opentnef = &has_command("opentnef")) &&
517 !($tnef = &has_command("tnef"))) {
518 $attach->{'error'} = "tnef command not installed";
521 # Can actually decode
522 local $tempfile = &transname();
523 open(TEMPFILE, ">$tempfile");
524 print TEMPFILE $attach->{'data'};
526 local $tempdir = &transname();
527 mkdir($tempdir, 0700);
529 system("$opentnef -d $tempdir -i $tempfile >/dev/null 2>&1");
532 system("$tnef -C $tempdir -f $tempfile >/dev/null 2>&1");
534 pop(@attach); # lose winmail.dat
535 opendir(DIR, $tempdir);
536 while($f = readdir(DIR)) {
537 next if ($f eq '.' || $f eq '..');
539 open(FILE, "$tempdir/$f");
544 local $ct = &guess_mime_type($f);
547 'idx' => scalar(@attach),
549 { 'content-type' => $ct },
551 [ [ 'Content-Type', $ct ] ],
556 unlink(glob("$tempdir/*"), $tempfile);
560 last if ($l >= $max || $lines[$l] eq "$bound--");
563 $_[0]->{'attach'} = \@attach;
565 elsif ($_[0]->{'body'} =~ /begin\s+([0-7]+)\s+(.*)/i) {
566 # Message contains uuencoded file(s)
567 local @lines = split(/\n/, $_[0]->{'body'});
568 local ($attach, $rest);
569 foreach $l (@lines) {
570 if ($l =~ /^begin\s+([0-7]+)\s+(.*)/i) {
571 $attach = { 'type' => &guess_mime_type($2),
572 'idx' => scalar(@{$_[0]->{'attach'}}),
575 push(@{$_[0]->{'attach'}}, $attach);
577 elsif ($l =~ /^end/ && $attach) {
581 $attach->{'data'} .= unpack("u", $l);
589 push(@{$_[0]->{'attach'}},
590 { 'type' => "text/plain",
591 'idx' => scalar(@{$_[0]->{'attach'}}),
596 elsif (lc($_[0]->{'header'}->{'content-transfer-encoding'}) eq 'base64') {
597 # Signed body section
599 $_[0]->{'attach'} = [ { 'type' => lc($ct),
602 'data' => &b64decode($_[0]->{'body'}) } ];
604 elsif (lc($_[0]->{'header'}->{'content-type'}) eq 'x-sun-attachment') {
605 # Sun attachment format, which can contain several sections
607 foreach $sun (split(/----------/, $_[0]->{'body'})) {
608 local ($headers, $rest) = split(/\r?\n\r?\n/, $sun, 2);
609 local $attach = { 'idx' => scalar(@{$_[0]->{'attach'}}),
612 if ($headers =~ /X-Sun-Data-Name:\s*(\S+)/) {
613 $attach->{'filename'} = $1;
615 if ($headers =~ /X-Sun-Data-Type:\s*(\S+)/) {
617 $attach->{'type'} = $st eq "text" ? "text/plain" :
618 $st eq "html" ? "text/html" :
619 $st =~ /\// ? $st : "application/octet-stream";
621 elsif ($attach->{'filename'}) {
623 &guess_mime_type($attach->{'filename'});
626 $attach->{'type'} = "text/plain"; # fallback
628 push(@{$_[0]->{'attach'}}, $attach);
632 # One big attachment (probably text)
633 local ($type, $body);
634 ($type = $ct) =~ s/;.*$//;
635 $type = 'text/plain' if (!$type);
636 if (lc($_[0]->{'header'}->{'content-transfer-encoding'}) eq 'base64') {
637 $body = &b64decode($_[0]->{'body'});
639 elsif (lc($_[0]->{'header'}->{'content-transfer-encoding'}) eq
640 'quoted-printable') {
641 $body = "ed_decode($_[0]->{'body'});
644 $body = $_[0]->{'body'};
647 $_[0]->{'attach'} = [ { 'type' => lc($type),
653 # Body is completely empty
654 $_[0]->{'attach'} = [ ];
657 delete($_[0]->{'body'}) if (!$_[2]);
660 # delete_mail(user|file, &mail, ...)
661 # Delete mail messages from a user by copying the file and rebuilding the index
665 local @m = sort { $a->{'line'} <=> $b->{'line'} } @_[1..@_-1];
667 defined($m->{'line'}) && defined($m->{'eline'}) &&
668 $m->{'eline'} > $m->{'line'} ||
669 &error("Message to delete is invalid, perhaps to due to ".
670 "out-of-date index");
674 local $f = &user_mail_file($_[0]);
675 local $ifile = &user_index_file($_[0]);
677 local (%dline, @fline);
678 local ($dpos = 0, $dlnum = 0);
679 local (@index, %index);
680 &build_dbm_index($_[0], \%index);
682 local $tmpf = $< == 0 ? "$f.del" :
683 $_[0] =~ /^\/.*\/([^\/]+)$/ ?
684 "$user_module_config_directory/$1.del" :
685 "$user_module_config_directory/$_[0].del";
687 $f = &resolve_links($f);
689 open(SOURCE, $f) || &error("Read failed : $!");
690 open(DEST, ">$tmpf") || &error("Open of $tmpf failed : $!");
692 if ($i >= @m || $lnum < $m[$i]->{'line'}) {
693 # Within a range that we want to preserve
696 local $w = (print DEST $_);
702 &error("Write to $tmpf failed : $e");
705 elsif (!$fline[$i]) {
706 # Start line of a message to delete
708 # Not actually a message! Fail now
712 &error("Index on $f is corrupt - did not find expected message start at line $lnum");
716 elsif ($lnum == $m[$i]->{'eline'}) {
717 # End line of the current message to delete
718 $dline{$m[$i]->{'line'}}++;
724 close(DEST) || &error("Write to $tmpf failed : $?");
725 local @st = stat($f);
726 unlink($f) if ($< == 0);
728 # Force a total index re-build (XXX lazy!)
729 $index{'mailcount'} = $in{'lastchange'} = 0;
736 system("cat ".quotemeta($tmpf)." > ".quotemeta($f).
737 " && rm -f ".quotemeta($tmpf));
739 chown($st[4], $st[5], $f);
743 # modify_mail(user|file, old, new, textonly)
744 # Modify one email message in a mailbox by copying the file and rebuilding
748 local $f = &user_mail_file($_[0]);
749 local $ifile = &user_index_file($_[0]);
751 local ($sizediff, $linesdiff);
753 &build_dbm_index($_[0], \%index);
755 # Replace the email that gets modified
756 local $tmpf = $< == 0 ? "$f.del" :
757 $_[0] =~ /^\/.*\/([^\/]+)$/ ?
758 "$user_module_config_directory/$1.del" :
759 "$user_module_config_directory/$_[0].del";
761 $f = &resolve_links($f);
764 open(DEST, ">$tmpf");
766 if ($lnum < $_[1]->{'line'} || $lnum > $_[1]->{'eline'}) {
767 # before or after the message to change
768 local $w = (print DEST $_);
774 &error("Write to $tmpf failed : $e");
777 elsif ($lnum == $_[1]->{'line'}) {
778 # found start of message to change .. put in the new one
780 local @ost = stat($tmpf);
781 local $nlines = &send_mail($_[2], $tmpf, $_[3], 1);
782 local @nst = stat($tmpf);
783 local $newsize = $nst[7] - $ost[7];
784 $sizediff = $newsize - $_[1]->{'size'};
785 $linesdiff = $nlines - ($_[1]->{'eline'} - $_[1]->{'line'} + 1);
786 open(DEST, ">>$tmpf");
791 close(DEST) || &error("Write failed : $!");
793 # Now update the index and delete the temp file
794 for($i=0; $i<$index{'mailcount'}; $i++) {
795 local @idx = split(/\0/, $index{$i});
796 if ($idx[1] > $_[1]->{'line'}) {
797 $idx[0] += $sizediff;
798 $idx[1] += $linesdiff;
799 $index{$i} = join("\0", @idx);
802 $index{'lastchange'} = time();
803 local @st = stat($f);
809 system("cat $tmpf >$f && rm -f $tmpf");
811 chown($st[4], $st[5], $f);
815 # send_mail(&mail, [file], [textonly], [nocr], [smtp-server],
816 # [smtp-user], [smtp-pass], [smtp-auth-mode],
817 # [¬ify-flags], [port])
818 # Send out some email message or append it to a file.
819 # Returns the number of lines written.
822 return 0 if (&is_readonly_mode());
825 local $sm = $_[4] || $config{'send_mode'};
826 local $eol = $_[3] || !$sm ? "\n" : "\r\n";
827 local $port = $_[9] || $config{'smtp_port'} || 25;
828 foreach $h (@{$_[0]->{'headers'}}) {
829 $header{lc($h->[0])} = $h->[1];
832 # Add the date header, always in english
833 &clear_time_locale();
834 local @tm = localtime(time());
835 push(@{$_[0]->{'headers'}},
836 [ 'Date', strftime("%a, %d %b %Y %H:%M:%S %z (%Z)", @tm) ])
837 if (!$header{'date'});
838 &reset_time_locale();
840 # Build list of destination email addresses
842 foreach my $f ("to", "cc", "bcc") {
844 push(@dests, &address_parts($header{$f}));
847 my $qdests = join(" ", map { quotemeta($_) } @dests);
849 local @from = &address_parts($header{'from'});
851 if (@from && $from[0] =~ /\S/) {
852 $fromaddr = $from[0];
855 local @uinfo = getpwuid($<);
856 $fromaddr = $uinfo[0] || "nobody";
857 $fromaddr .= '@'.&get_system_hostname();
859 local $esmtp = $_[8] ? 1 : 0;
861 # Just append the email to a file using mbox format
862 open(MAIL, ">>$_[1]") || &error("Write failed : $!");
864 print MAIL $_[0]->{'fromline'} ? $_[0]->{'fromline'}.$eol :
865 &make_from_line($fromaddr).$eol;
868 # Connect to SMTP server
869 &open_socket($sm, $port, MAIL);
872 &smtp_command(MAIL, "ehlo ".&get_system_hostname()."\r\n");
875 &smtp_command(MAIL, "helo ".&get_system_hostname()."\r\n");
878 # Get username and password from parameters, or from module config
879 local $user = $_[5] || $userconfig{'smtp_user'} || $config{'smtp_user'};
880 local $pass = $_[6] || $userconfig{'smtp_pass'} || $config{'smtp_pass'};
881 local $auth = $_[7] || $userconfig{'smtp_auth'} ||
882 $config{'smtp_auth'} || "Cram-MD5";
884 # Send authentication commands
885 eval "use Authen::SASL";
887 &error("Perl module <tt>Authen::SASL</tt> is needed for SMTP authentication");
889 my $sasl = Authen::SASL->new('mechanism' => uc($auth),
894 &error("Failed to create Authen::SASL object") if (!$sasl);
895 local $conn = $sasl->client_new("smtp", &get_system_hostname());
896 local $arv = &smtp_command(MAIL, "auth $auth\r\n", 1);
897 if ($arv =~ /^(334)\s+(.*)/) {
898 # Server says to go ahead
900 local $initial = $conn->client_start();
903 local $enc = &encode_base64($initial);
905 $arv = &smtp_command(MAIL, "$enc\r\n", 1);
906 if ($arv =~ /^(\d+)\s+(.*)/) {
911 &error("Unknown SMTP authentication response : $arv");
917 local $message = &decode_base64($extra);
918 local $return = $conn->client_step($message);
919 local $enc = &encode_base64($return);
921 $arv = &smtp_command(MAIL, "$enc\r\n", 1);
922 if ($arv =~ /^(\d+)\s+(.*)/) {
927 &error("SMTP authentication failed : $arv");
932 &error("Unknown SMTP authentication response : $arv");
938 &smtp_command(MAIL, "mail from: <$fromaddr>\r\n");
939 local $notify = $_[8] ? " NOTIFY=".join(",", @{$_[8]}) : "";
940 foreach my $u (@dests) {
941 &smtp_command(MAIL, "rcpt to: <$u>$notify\r\n");
943 &smtp_command(MAIL, "data\r\n");
945 elsif (defined(&send_mail_program)) {
946 # Use specified mail injector
947 local $cmd = &send_mail_program($fromaddr, \@dests);
948 $cmd || &error("No mail program was found on your system!");
949 open(MAIL, "| $cmd >/dev/null 2>&1");
951 elsif ($config{'qmail_dir'}) {
953 open(MAIL, "| $config{'qmail_dir'}/bin/qmail-inject");
955 elsif ($config{'postfix_control_command'}) {
956 # Start postfix's sendmail wrapper
957 local $cmd = -x "/usr/lib/sendmail" ? "/usr/lib/sendmail" :
958 &has_command("sendmail");
959 $cmd || &error($text{'send_ewrapper'});
960 open(MAIL, "| $cmd -f$fromaddr $qdests >/dev/null 2>&1");
964 &has_command($config{'sendmail_path'}) ||
965 &error(&text('send_epath', "<tt>$config{'sendmail_path'}</tt>"));
966 open(MAIL, "| $config{'sendmail_path'} -f$fromaddr $qdests >/dev/null 2>&1");
968 local $ctype = "multipart/mixed";
970 foreach $h (@{$_[0]->{'headers'}}) {
971 if (defined($_[0]->{'body'}) || $_[2]) {
972 print MAIL $h->[0],": ",$h->[1],$eol;
976 if ($h->[0] !~ /^(MIME-Version|Content-Type)$/i) {
977 print MAIL $h->[0],": ",$h->[1],$eol;
980 elsif (lc($h->[0]) eq 'content-type') {
984 if (lc($h->[0]) eq 'message-id') {
989 # Add a message-id header if missing
990 $main::mailboxes_message_id_count++;
991 print MAIL "Message-Id: <",time().".".$$.".".
992 $main::mailboxes_message_id_count."\@".
993 &get_system_hostname(),">",$eol;
996 # Work out first attachment content type
997 local ($ftype, $fenc);
998 if (@{$_[0]->{'attach'}} >= 1) {
999 local $first = $_[0]->{'attach'}->[0];
1000 $ftype = "text/plain";
1001 foreach my $h (@{$first->{'headers'}}) {
1002 if (lc($h->[0]) eq "content-type") {
1005 if (lc($h->[0]) eq "content-transfer-encoding") {
1011 if (defined($_[0]->{'body'})) {
1012 # Use original mail body
1015 $_[0]->{'body'} =~ s/\r//g;
1016 $_[0]->{'body'} =~ s/\n\.\n/\n\. \n/g;
1017 $_[0]->{'body'} =~ s/\n/$eol/g;
1018 $_[0]->{'body'} .= $eol if ($_[0]->{'body'} !~ /\n$/);
1019 (print MAIL $_[0]->{'body'}) || &error("Write failed : $!");
1020 $lnum += ($_[0]->{'body'} =~ tr/\n/\n/);
1022 elsif (!@{$_[0]->{'attach'}}) {
1023 # No content, so just send empty email
1024 print MAIL "Content-Type: text/plain",$eol;
1028 elsif (!$_[2] || $ftype !~ /text\/plain/i ||
1029 $fenc =~ /quoted-printable|base64/) {
1030 # Sending MIME-encoded email
1031 if ($ctype !~ /multipart\/report/i) {
1034 print MAIL "MIME-Version: 1.0",$eol;
1035 local $bound = "bound".time();
1036 print MAIL "Content-Type: $ctype; boundary=\"$bound\"",$eol;
1041 print MAIL "This is a multi-part message in MIME format.",$eol;
1043 foreach $a (@{$_[0]->{'attach'}}) {
1045 print MAIL "--",$bound,$eol;
1048 foreach $h (@{$a->{'headers'}}) {
1049 print MAIL $h->[0],": ",$h->[1],$eol;
1051 if (lc($h->[0]) eq 'content-transfer-encoding');
1056 if (lc($enc) eq 'base64') {
1057 local $enc = &encode_base64($a->{'data'});
1059 $enc =~ s/\n/$eol/g;
1061 $lnum += ($enc =~ tr/\n/\n/);
1064 $a->{'data'} =~ s/\r//g;
1065 $a->{'data'} =~ s/\n\.\n/\n\. \n/g;
1066 $a->{'data'} =~ s/\n/$eol/g;
1067 print MAIL $a->{'data'};
1068 $lnum += ($a->{'data'} =~ tr/\n/\n/);
1069 if ($a->{'data'} !~ /\n$/) {
1076 (print MAIL "--",$bound,"--",$eol) || &error("Write failed : $!");
1081 # Sending text-only mail from first attachment
1082 local $a = $_[0]->{'attach'}->[0];
1085 $a->{'data'} =~ s/\r//g;
1086 $a->{'data'} =~ s/\n/$eol/g;
1087 (print MAIL $a->{'data'}) || &error("Write failed : $!");
1088 $lnum += ($a->{'data'} =~ tr/\n/\n/);
1089 if ($a->{'data'} !~ /\n$/) {
1094 if ($sm && !$_[1]) {
1095 &smtp_command(MAIL, ".$eol");
1096 &smtp_command(MAIL, "quit$eol");
1099 # Only bother to report an error on close if writing to a file
1101 &error("Write failed : $!");
1107 # unparse_mail(&attachments, eol, boundary)
1108 # Convert an array of attachments into MIME format, and return them as an
1112 local ($attach, $eol, $bound) = @_;
1114 foreach my $a (@$attach) {
1116 push(@rv, "--".$bound.$eol);
1118 foreach my $h (@{$a->{'headers'}}) {
1119 push(@rv, $h->[0].": ".$h->[1].$eol);
1121 if (lc($h->[0]) eq 'content-transfer-encoding');
1124 if (lc($enc) eq 'base64') {
1125 local $enc = &encode_base64($a->{'data'});
1127 foreach my $l (split(/\n/, $enc)) {
1132 $a->{'data'} =~ s/\r//g;
1133 $a->{'data'} =~ s/\n\.\n/\n\. \n/g;
1134 foreach my $l (split(/\n/, $a->{'data'})) {
1140 push(@rv, "--".$bound."--".$eol);
1145 # mail_size(&mail, [textonly])
1146 # Returns the size of an email message in bytes
1149 local ($mail, $textonly) = @_;
1150 local $temp = &transname();
1151 &send_mail($mail, $temp, $textonly);
1152 local @st = stat($temp);
1158 # Converts a string from base64 format to normal
1161 local($str) = $_[0];
1163 $str =~ tr|A-Za-z0-9+=/||cd;
1165 $str =~ tr|A-Za-z0-9+/| -_|;
1166 while ($str =~ /(.{1,60})/gs) {
1167 my $len = chr(32 + length($1)*3/4);
1168 $res .= unpack("u", $len . $1 );
1173 # can_read_mail(user)
1176 return 1 if ($_[0] && $access{'sent'} eq $_[0]);
1177 local @u = getpwnam($_[0]);
1179 return 0 if ($_[0] =~ /\.\./);
1180 return 0 if ($access{'mmode'} == 0);
1181 return 1 if ($access{'mmode'} == 1);
1183 if ($access{'mmode'} == 2) {
1184 foreach $u (split(/\s+/, $access{'musers'})) {
1185 return 1 if ($u eq $_[0]);
1189 elsif ($access{'mmode'} == 4) {
1190 return 1 if ($_[0] eq $remote_user);
1192 elsif ($access{'mmode'} == 5) {
1193 return $u[3] eq $access{'musers'};
1195 elsif ($access{'mmode'} == 3) {
1196 foreach $u (split(/\s+/, $access{'musers'})) {
1197 return 0 if ($u eq $_[0]);
1201 elsif ($access{'mmode'} == 6) {
1202 return ($_[0] =~ /^$access{'musers'}$/);
1204 elsif ($access{'mmode'} == 7) {
1205 return (!$access{'musers'} || $u[2] >= $access{'musers'}) &&
1206 (!$access{'musers2'} || $u[2] <= $access{'musers2'});
1208 return 0; # can't happen!
1215 local $conf = &get_sendmailcf();
1216 foreach $d (&find_type("D", $conf)) {
1217 if ($d->{'value'} =~ /^M\s*(\S*)/) { $masq = $1; }
1219 return $masq ? $masq : &get_system_hostname();
1222 # mail_from_queue(qfile, [dfile|"auto"])
1223 # Reads a message from the Sendmail mail queue
1226 local $mail = { 'file' => $_[0] };
1227 $mail->{'quar'} = $_[0] =~ /\/hf/;
1228 $mail->{'lost'} = $_[0] =~ /\/Qf/;
1229 if ($_[1] eq "auto") {
1230 $mail->{'dfile'} = $_[0];
1231 $mail->{'dfile'} =~ s/\/(qf|hf|Qf)/\/df/;
1234 $mail->{'dfile'} = $_[1];
1236 $mail->{'lfile'} = $_[0];
1237 $mail->{'lfile'} =~ s/\/(qf|hf|Qf)/\/xf/;
1240 open(QF, $_[0]) || return undef;
1244 $mail->{'status'} = $1;
1246 elsif (/^H\?[^\?]*\?(\S+):\s+(.*)/ || /^H(\S+):\s+(.*)/) {
1247 push(@headers, [ $1, $2 ]);
1248 $mail->{'rawheaders'} .= "$1: $2\n";
1250 elsif (/^\s+(.*)/) {
1251 $headers[$#headers]->[1] .= $1 unless($#headers < 0);
1252 $mail->{'rawheaders'} .= $_."\n";
1256 $mail->{'headers'} = \@headers;
1257 foreach $h (@headers) {
1258 $mail->{'header'}->{lc($h->[0])} = $h->[1];
1261 if ($mail->{'dfile'}) {
1262 # Read the mail body
1263 open(DF, $mail->{'dfile'});
1265 $mail->{'body'} .= $_;
1269 local $datafile = $mail->{'dfile'};
1271 ($datafile = $mail->{'file'}) =~ s/\/(qf|hf|Qf)/\/df/;
1273 local @st0 = stat($mail->{'file'});
1274 local @st1 = stat($datafile);
1275 $mail->{'size'} = $st0[7] + $st1[7];
1279 # wrap_lines(text, width)
1280 # Given a multi-line string, return an array of lines wrapped to
1286 foreach $rest (split(/\n/, $_[0])) {
1287 if ($rest =~ /\S/) {
1288 while($rest =~ /^(.{1,$w}\S*)\s*([\0-\377]*)$/) {
1294 # Empty line .. keep as it is
1301 # smtp_command(handle, command, no-error)
1304 local ($m, $c) = @_;
1307 if ($r !~ /^[23]\d+/ && !$_[2]) {
1308 &error(&text('send_esmtp', "<tt>".&html_escape($c)."</tt>",
1309 "<tt>".&html_escape($r)."</tt>"));
1312 if ($r =~ /^(\d+)\-/) {
1313 # multi-line ESMTP response!
1317 if ($nr =~ /^(\d+)\-(.*)/) {
1320 elsif ($nr =~ /^(\d+)\s+(.*)/) {
1329 # address_parts(string)
1330 # Returns the email addresses in a string
1333 local @rv = map { $_->[0] } &split_addresses($_[0]);
1334 return wantarray ? @rv : $rv[0];
1337 # link_urls(text, separate)
1338 # Converts URLs into HTML links
1342 local $tar = $_[1] ? "target=link".int(rand()*100000) : "";
1343 $r =~ s/((http|ftp|https|mailto):[^><"'\s]+[^><"'\s\.\)])/<a href="$1" $tar>$1<\/a>/g;
1347 # link_urls_and_escape(text, separate)
1348 # HTML escapes some text, as well as properly linking URLs in it
1349 sub link_urls_and_escape
1353 local $tar = $_[1] ? " target=link".int(rand()*100000) : "";
1354 while($l =~ /^(.*?)((http|ftp|https|mailto):[^><"'\s]+[^><"'\s\.\)])(.*)/) {
1355 local ($before, $url, $after) = ($1, $2, $4);
1356 $rv .= &eucconv_and_escape($before)."<a href='$url' $tar>".
1357 &html_escape($url)."</a>";
1360 $rv .= &eucconv_and_escape($l);
1364 # links_urls_new_target(html)
1365 # Converts any links without targets to open in a new window
1366 sub links_urls_new_target
1370 while($l =~ s/^([\0-\377]*?)<\s*a\s+([^>]*href[^>]*)>//i) {
1371 local ($before, $a) = ($1, $2);
1372 if ($a !~ /target\s*=/i) {
1373 $a .= " target=link".int(rand()*100000);
1375 $rv .= $before."<a ".$a.">";
1384 local @lines = split(/\n/, $_[0]);
1386 for($l=0; $lines[$l] !~ /begin\s+([0-7]+)\s/i; $l++) { }
1387 while($lines[++$l]) {
1388 $data .= unpack("u", $lines[$l]);
1393 # simplify_date(datestring, [format])
1394 # Given a date from an email header, convert to the user's preferred format
1397 local ($date, $fmt) = @_;
1398 local $u = &parse_mail_date($date);
1400 $fmt ||= $userconfig{'date_fmt'} || $config{'date_fmt'} || "dmy";
1401 local $strf = $fmt eq "dmy" ? "%d/%m/%Y" :
1402 $fmt eq "mdy" ? "%m/%d/%Y" :
1404 return strftime("$strf %H:%M", localtime($u));
1406 elsif ($date =~ /^(\S+),\s+0*(\d+)\s+(\S+)\s+(\d+)\s+(\d+):(\d+)/) {
1407 return "$2/$3/$4 $5:$6";
1409 elsif ($date =~ /^0*(\d+)\s+(\S+)\s+(\d+)\s+(\d+):(\d+)/) {
1410 return "$1/$2/$3 $4:$5";
1415 # simplify_from(from)
1416 # Simplifies a From: address for display in the mail list. Only the first
1417 # address is returned.
1420 local $rv = &eucconv(&decode_mimewords($_[0]));
1421 local @sp = &split_addresses($rv);
1423 return $text{'mail_nonefrom'};
1426 local $first = &html_escape($sp[0]->[1] ? $sp[0]->[1] : $sp[0]->[2]);
1427 if (length($first) > 80) {
1428 return substr($first, 0, 80)." ..";
1431 return $first.(@sp > 1 ? " , ..." : "");
1436 # simplify_subject(subject)
1437 # Simplifies and truncates a subject for display in the mail list
1438 sub simplify_subject
1440 local $rv = &eucconv(&decode_mimewords($_[0]));
1441 $rv = substr($rv, 0, 80)." .." if (length($rv) > 80);
1442 return &html_escape($rv);
1445 # quoted_decode(text)
1446 # Converts quoted-printable format to the original
1450 $t =~ s/[ \t]+?(\r?\n)/$1/g;
1452 $t =~ s/(^|[^\r])\n\Z/$1\r\n/;
1453 $t =~ s/=([a-fA-F0-9]{2})/pack("c",hex($1))/ge;
1457 # quoted_encode(text)
1458 # Encodes text to quoted-printable format
1462 $t =~ s/([=\177-\377])/sprintf("=%2.2X",ord($1))/ge;
1466 # decode_mimewords(string)
1467 # Converts a string in MIME words format like
1468 # =?ISO-8859-1?Q?Keld_J=F8rn_Simonsen?= to actual 8-bit characters
1469 sub decode_mimewords {
1473 $@ = ''; ### error-return
1475 ### Collapse boundaries between adjacent encoded words:
1476 $encstr =~ s{(\?\=)\r?\n[ \t](\=\?)}{$1$2}gs;
1478 ### print STDOUT "ENC = [", $encstr, "]\n";
1481 my ($charset, $encoding, $enc, $dec);
1483 last if (pos($encstr) >= length($encstr));
1484 my $pos = pos($encstr); ### save it
1486 ### Case 1: are we looking at "=?..?..?="?
1487 if ($encstr =~ m{\G # from where we left off..
1488 =\?([^?]*) # "=?" + charset +
1489 \?([bq]) # "?" + encoding +
1490 \?([^?]+) # "?" + data maybe with spcs +
1493 ($charset, $encoding, $enc) = ($1, lc($2), $3);
1494 $dec = (($encoding eq 'q') ? _decode_Q($enc) : _decode_B($enc));
1495 push @tokens, [$dec, $charset];
1499 ### Case 2: are we looking at a bad "=?..." prefix?
1500 ### We need this to detect problems for case 3, which stops at "=?":
1501 pos($encstr) = $pos; # reset the pointer.
1502 if ($encstr =~ m{\G=\?}xg) {
1503 $@ .= qq|unterminated "=?..?..?=" in "$encstr" (pos $pos)\n|;
1504 push @tokens, ['=?'];
1508 ### Case 3: are we looking at ordinary text?
1509 pos($encstr) = $pos; # reset the pointer.
1510 if ($encstr =~ m{\G # from where we left off...
1511 ([\x00-\xFF]*? # shortest possible string,
1512 \n*) # followed by 0 or more NLs,
1513 (?=(\Z|=\?)) # terminated by "=?" or EOS
1515 length($1) or die "MIME::Words: internal logic err: empty token\n";
1521 die "MIME::Words: unexpected case:\n($encstr) pos $pos\n\t".
1522 "Please alert developer.\n";
1524 return join('',map {$_->[0]} @tokens);
1528 # Private: used by _decode_header() to decode "Q" encoding, which is
1529 # almost, but not exactly, quoted-printable. :-P
1532 $str =~ s/_/\x20/g; # RFC-1522, Q rule 2
1533 $str =~ s/=([\da-fA-F]{2})/pack("C", hex($1))/ge; # RFC-1522, Q rule 1
1538 # Private: used by _decode_header() to decode "B" encoding.
1541 &decode_base64($str);
1544 # encode_mimewords(string, %params)
1545 # Converts a word with 8-bit characters to MIME words format
1546 sub encode_mimewords
1548 my ($rawstr, %params) = @_;
1549 my $charset = $params{Charset} || 'ISO-8859-1';
1550 my $defenc = uc($charset) eq 'ISO-2022-JP' ? 'b' : 'q';
1551 my $encoding = lc($params{Encoding} || $defenc);
1552 my $NONPRINT = "\\x00-\\x1F\\x7F-\\xFF";
1554 if ($rawstr =~ /^[\x20-\x7E]*$/) {
1555 # No encoding needed
1559 ### Encode any "words" with unsafe characters.
1560 ### We limit such words to 18 characters, to guarantee that the
1561 ### worst-case encoding give us no more than 54 + ~10 < 75 characters
1563 $rawstr =~ s{([ a-zA-Z0-9\x7F-\xFF]{1,18})}{ ### get next "word"
1565 $word =~ /(?:[$NONPRINT])|(?:^\s+$)/o ?
1566 encode_mimeword($word, $encoding, $charset) : # unsafe chars
1569 $rawstr =~ s/\?==\?/?= =?/g;
1573 # encode_mimewords_address(string, %params)
1574 # Given a string containing addresses into one with real names mime-words
1576 sub encode_mimewords_address
1578 my ($rawstr, %params) = @_;
1579 my $charset = $params{Charset} || 'ISO-8859-1';
1580 my $defenc = uc($charset) eq 'ISO-2022-JP' ? 'b' : 'q';
1581 my $encoding = lc($params{Encoding} || $defenc);
1582 if ($rawstr =~ /^[\x20-\x7E]*$/) {
1583 # No encoding needed
1587 foreach my $addr (&split_addresses($rawstr)) {
1588 my ($email, $name, $orig) = @$addr;
1589 if ($name =~ /^[\x20-\x7E]*$/) {
1590 # No encoding needed
1595 my $ename = encode_mimeword($name, $encoding, $charset);
1596 push(@rv, $ename." <".$email.">");
1599 return join(", ", @rv);
1602 # encode_mimeword(string, [encoding], [charset])
1603 # Converts a word with 8-bit characters to MIME words format
1607 my $encoding = uc(shift || 'Q');
1608 my $charset = uc(shift || 'ISO-8859-1');
1609 my $encfunc = (($encoding eq 'Q') ? \&_encode_Q : \&_encode_B);
1610 return "=?$charset?$encoding?" . &$encfunc($word) . "?=";
1614 # Private: used by _encode_header() to decode "Q" encoding, which is
1615 # almost, but not exactly, quoted-printable. :-P
1618 my $NONPRINT = "\\x00-\\x1F\\x7F-\\xFF";
1619 $str =~ s{([ _\?\=$NONPRINT])}{sprintf("=%02X", ord($1))}eog;
1624 # Private: used by _decode_header() to decode "B" encoding.
1627 my $enc = &encode_base64($str);
1632 # user_mail_file(user|file, [other details])
1635 if ($_[0] =~ /^\//) {
1638 elsif ($config{'mail_dir'}) {
1639 return &mail_file_style($_[0], $config{'mail_dir'},
1640 $config{'mail_style'});
1643 return "$_[7]/$config{'mail_file'}";
1646 local @u = getpwnam($_[0]);
1647 return "$u[7]/$config{'mail_file'}";
1651 # mail_file_style(user, basedir, style)
1655 return "$_[1]/$_[0]";
1657 elsif ($_[2] == 1) {
1658 return $_[1]."/".substr($_[0], 0, 1)."/".$_[0];
1660 elsif ($_[2] == 2) {
1661 return $_[1]."/".substr($_[0], 0, 1)."/".
1662 substr($_[0], 0, 2)."/".$_[0];
1665 return $_[1]."/".substr($_[0], 0, 1)."/".
1666 substr($_[0], 1, 1)."/".$_[0];
1670 # user_index_file(user|file)
1676 local $hn = &get_system_hostname();
1677 if ($_[0] =~ /^\/.*\/([^\/]+)$/) {
1678 # A file .. the index file is in ~/.usermin/mailbox or
1679 # /etc/webmin/mailboxes
1680 if ($user_module_config_directory && $config{'shortindex'}) {
1681 # Use short name for index file
1682 $f = "$user_module_config_directory/$1.findex";
1685 $f = $user_module_config_directory ?
1686 "$user_module_config_directory/$us.findex" :
1687 "$module_config_directory/$us.findex";
1691 # A username .. the index file is in /etc/webmin/mailboxes
1692 $f = $user_module_config_directory ?
1693 "$user_module_config_directory/$_[0].index" :
1694 "$module_config_directory/$_[0].index";
1696 return -r $f && !-r "$f.$hn" ? $f : "$f.$hn";
1699 # extract_mail(data)
1700 # Converts the text of a message into mail object.
1703 local $text = $_[0];
1705 local ($amail, @aheaders, $i);
1706 local @alines = split(/\n/, $text);
1707 while($i < @alines && $alines[$i]) {
1708 if ($alines[$i] =~ /^(\S+):\s*(.*)/) {
1709 push(@aheaders, [ $1, $2 ]);
1710 $amail->{'rawheaders'} .= $alines[$i]."\n";
1712 elsif ($alines[$i] =~ /^\s+(.*)/) {
1713 $aheaders[$#aheaders]->[1] .= $1 unless($#aheaders < 0);
1714 $amail->{'rawheaders'} .= $alines[$i]."\n";
1718 $amail->{'headers'} = \@aheaders;
1719 foreach $h (@aheaders) {
1720 $amail->{'header'}->{lc($h->[0])} = $h->[1];
1722 splice(@alines, 0, $i);
1723 $amail->{'body'} = join("\n", @alines)."\n";
1727 # split_addresses(string)
1728 # Splits a comma-separated list of addresses into [ email, real-name, original ]
1732 local (@rv, $str = $_[0]);
1735 if ($str =~ /^[\s,]*(([^<>\(\)\s]+)\s+\(([^\(\)]+)\))(.*)$/) {
1736 # An address like foo@bar.com (Fooey Bar)
1737 push(@rv, [ $2, $3, $1 ]);
1740 elsif ($str =~ /^[\s,]*("([^"]+)"\s*<([^\s<>,]+)>)(.*)$/ ||
1741 $str =~ /^[\s,]*(([^<>\@]+)\s+<([^\s<>,]+)>)(.*)$/ ||
1742 $str =~ /^[\s,]*(([^<>\@]+)<([^\s<>,]+)>)(.*)$/ ||
1743 $str =~ /^[\s,]*(([^<>\[\]]+)\s+\[mailto:([^\s\[\]]+)\])(.*)$/||
1744 $str =~ /^[\s,]*(()<([^<>,]+)>)(.*)/ ||
1745 $str =~ /^[\s,]*(()([^\s<>,]+))(.*)/) {
1746 # Addresses like "Fooey Bar" <foo@bar.com>
1747 # Fooey Bar <foo@bar.com>
1748 # Fooey Bar<foo@bar.com>
1749 # Fooey Bar [mailto:foo@bar.com]
1752 # foo@bar.com or foo
1753 my ($all, $name, $email, $rest) = ($1, $2, $3, $4);
1756 push(@rv, [ $email, $name eq "," ? "" : $name, $all ]);
1766 $match_ascii = '\x1b\([BHJ]([\t\x20-\x7e]*)';
1767 $match_jis = '\x1b\$[@B](([\x21-\x7e]{2})*)';
1771 if ($current_lang eq 'ja_JP.euc') {
1772 s/$match_jis/&j2e($1)/geo;
1773 s/$match_ascii/$1/go;
1780 tr/\x21-\x7e/\xa1-\xfe/;
1784 # eucconv_and_escape(string)
1785 sub eucconv_and_escape {
1786 return &html_escape(&eucconv($_[0]));
1789 # list_maildir(file, [start], [end], [headersonly])
1790 # Returns a subset of mail from a maildir format directory
1793 local (@rv, $i, $f);
1794 &mark_read_maildir($_[0]);
1795 local @files = &get_maildir_files($_[0]);
1797 local ($start, $end);
1798 if (!defined($_[1])) {
1803 $start = @files + $_[2] - 1;
1804 $end = @files + $_[1] - 1;
1805 $start = 0 if ($start < 0);
1810 $end = @files-1 if ($end >= @files);
1812 foreach $f (@files) {
1813 if ($i < $start || $i > $end) {
1814 # Skip files outside requested index range
1819 local $mail = &read_mail_file($f, $_[3]);
1820 $mail->{'idx'} = $i++;
1821 $mail->{'id'} = $f; # ID is relative path, like cur/4535534
1822 $mail->{'id'} = substr($mail->{'id'}, length($_[0])+1);
1828 # idlist_maildir(file)
1829 # Returns a list of files in a maildir, which form the IDs
1833 &mark_read_maildir($file);
1834 return map { substr($_, length($file)+1) } &get_maildir_files($file);
1837 # select_maildir(file, &ids, headersonly)
1838 # Returns a list of messages with the given IDs, from a maildir directory
1841 local ($file, $ids, $headersonly) = @_;
1842 &mark_read_maildir($file);
1843 local @files = &get_maildir_files($file);
1845 foreach my $i (@$ids) {
1846 local $path = "$file/$i";
1847 local $mail = &read_mail_file($path, $headersonly);
1848 if (!$mail && $path =~ /^(.*)\/(cur|tmp|new)\/([^:]*)(:2,([A-Za-z]*))?$/) {
1849 # Flag may have changed - update path
1850 local $suffix = "$2/$3";
1851 local ($newfile) = grep
1852 { substr($_, length($file)+1, length($suffix)) eq $suffix }
1856 $mail = &read_mail_file($path, $headersonly);
1859 if (!$mail && $path =~ /\/cur\//) {
1860 # May have moved - update path
1861 $path =~ s/\/cur\//\/new\//g;
1862 $mail = &read_mail_file($path, $headersonly);
1865 # Set ID from corrected path
1866 $mail->{'id'} = $path;
1867 $mail->{'id'} = substr($mail->{'id'}, length($file)+1);
1868 # Get index in directory
1869 $mail->{'idx'} = &indexof($path, @files);
1876 # Get ordered list of message files (with in-memory and on-disk caching, as
1878 # get_maildir_files(directory)
1879 sub get_maildir_files
1881 # Work out last modified time
1883 foreach my $d ("$_[0]/cur", "$_[0]/new") {
1884 local @dst = stat($d);
1885 $newest = $dst[9] if ($dst[9] > $newest);
1887 local $skipt = $config{'maildir_deleted'} || $userconfig{'maildir_deleted'};
1890 if (defined($main::list_maildir_cache{$_[0]}) &&
1891 $main::list_maildir_cache_time{$_[0]} == $newest) {
1892 # Use the in-memory cache cache
1893 @files = @{$main::list_maildir_cache{$_[0]}};
1896 # Check the on-disk cache file
1897 local $cachefile = &get_maildir_cachefile($_[0]);
1898 local @cst = $cachefile ? stat($cachefile) : ( );
1899 if ($cst[9] >= $newest) {
1900 # Can read the cache
1901 open(CACHE, $cachefile);
1904 push(@files, $_[0]."/".$_);
1907 $main::list_maildir_cache_time{$_[0]} = $cst[9];
1912 foreach my $d ("cur", "new") {
1913 opendir(DIR, "$_[0]/$d");
1914 while(my $f = readdir(DIR)) {
1915 next if ($f eq "." || $f eq "..");
1916 if ($skipt && $f =~ /:2,([A-Za-z]*T[A-Za-z]*)$/) {
1917 # Flagged as deleted by IMAP .. skip
1920 push(@shorts, "$d/$f")
1924 @shorts = sort { substr($a, 4) cmp substr($b, 4) } @shorts;
1925 @files = map { "$_[0]/$_" } @shorts;
1927 # Write out the on-disk cache
1929 &open_tempfile(CACHE, ">$cachefile", 1);
1931 foreach my $f (@shorts) {
1932 my $ok = (print CACHE $f,"\n");
1935 &close_tempfile(CACHE) if (!$err);
1936 local @st = stat($_[0]);
1938 # Cache should have some ownership as directory
1939 &set_ownership_permissions($st[4], $st[5],
1943 $main::list_maildir_cache_time{$_[0]} = $st[9];
1945 $main::list_maildir_cache{$_[0]} = \@files;
1950 # search_maildir(file, field, what)
1951 # Search for messages in a maildir directory, and return the results
1954 return &advanced_search_maildir($_[0], [ [ $_[1], $_[2] ] ], 1);
1957 # advanced_search_maildir(user|file, &fields, andmode, [&limit], [headersonly])
1958 # Search for messages in a maildir directory, and return the results
1959 sub advanced_search_maildir
1961 &mark_read_maildir($_[0]);
1964 if ($_[3] && $_[3]->{'latest'}) {
1966 $max = -$_[3]->{'latest'};
1968 local $headersonly = $_[4] && !&matches_needs_body($_[1]);
1969 foreach $mail (&list_maildir($_[0], $min, $max, $headersonly)) {
1970 push(@rv, $mail) if ($mail &&
1971 &mail_matches($_[1], $_[2], $mail));
1976 # mark_read_maildir(dir)
1977 # Move any messages in the 'new' directory of this maildir to 'cur'
1978 sub mark_read_maildir
1981 local @files = &get_maildir_files($dir);
1983 foreach my $nf (@files) {
1984 if (substr($nf, length($dir)+1, 3) eq "new") {
1986 $cf =~ s/\/new\//\/cur\//g;
1987 if (rename($nf, $cf)) {
1996 $main::list_maildir_cache{$dir} = \@files;
1997 local $cachefile = &get_maildir_cachefile($dir);
1999 &open_tempfile(CACHE, ">$cachefile", 1);
2000 foreach my $f (@files) {
2001 local $short = substr($f, length($dir)+1);
2002 &print_tempfile(CACHE, $short,"\n");
2004 &close_tempfile(CACHE);
2005 local @st = stat($_[0]);
2007 &set_ownership_permissions($st[4], $st[5],
2014 # delete_maildir(&mail, ...)
2015 # Delete messages from a maildir directory
2020 # Find all maildirs being deleted from
2023 if ($m->{'file'} =~ /^(.*)\/(cur|new)\/([^\/]+)$/) {
2024 $dirs{$1}->{"$2/$3"} = 1;
2028 # Delete from caches
2029 foreach my $dir (keys %dirs) {
2030 local $cachefile = &get_maildir_cachefile($dir);
2031 next if (!$cachefile);
2032 local @cst = stat($cachefile);
2035 # Work out last modified time, and don't update cache if too new
2037 foreach my $d ("$dir/cur", "$dir/new") {
2038 local @dst = stat($d);
2039 $newest = $dst[9] if ($dst[9] > $newest);
2041 next if ($newest > $cst[9]);
2043 local $lref = &read_file_lines($cachefile);
2044 for(my $i=0; $i<@$lref; $i++) {
2045 if ($dirs{$dir}->{$lref->[$i]}) {
2046 # Found an entry to remove
2047 splice(@$lref, $i--, 1);
2050 &flush_file_lines($cachefile);
2053 # Actually delete the files
2055 unlink($m->{'file'});
2060 # modify_maildir(&oldmail, &newmail, textonly)
2061 # Replaces a message in a maildir directory
2064 unlink($_[0]->{'file'});
2065 &send_mail($_[1], $_[0]->{'file'}, $_[2], 1);
2068 # write_maildir(&mail, directory, textonly)
2069 # Adds some message in maildir format to a directory
2072 # Work out last modified time, and don't update cache if too new
2073 local $cachefile = &get_maildir_cachefile($_[1]);
2076 local @cst = stat($cachefile);
2079 foreach my $d ("$dir/cur", "$dir/new") {
2080 local @dst = stat($d);
2081 $newest = $dst[9] if ($dst[9] > $newest);
2083 $up2date = 1 if ($newest <= $cst[9]);
2087 # Select a unique filename and write to it
2088 local $now = time();
2089 $_[0]->{'id'} = &unique_maildir_filename($_[1]);
2090 $mf = "$_[1]/$_[0]->{'id'}";
2091 &send_mail($_[0], $mf, $_[2], 1);
2092 $_[0]->{'file'} = $mf;
2094 # Set ownership of the new message file to match the directory
2095 local @st = stat($_[1]);
2097 &set_ownership_permissions($st[4], $st[5], undef, $mf);
2100 # Create tmp and new sub-dirs, if missing
2101 foreach my $sd ("tmp", "new") {
2102 local $sdpath = "$_[1]/$sd";
2104 mkdir($sdpath, 0755);
2106 &set_ownership_permissions($st[4], $st[5],
2112 if ($up2date && $cachefile) {
2113 # Bring cache up to date
2115 local $lref = &read_file_lines($cachefile);
2116 push(@$lref, $_[0]->{'id'});
2117 &flush_file_lines($cachefile);
2121 # unique_maildir_filename(dir)
2122 # Returns a filename for a new message in a maildir, relative to the directory
2123 sub unique_maildir_filename
2126 mkdir("$dir/cur", 0755);
2127 local $now = time();
2128 local $hn = &get_system_hostname();
2129 ++$main::write_maildir_count;
2132 $rv = "cur/$now.$$.$main::write_maildir_count.$hn";
2134 } while(-r "$dir/$rv");
2138 # empty_maildir(file)
2139 # Delete all messages in an maildir directory
2143 foreach $d ("$_[0]/cur", "$_[0]/new") {
2146 while($f = readdir(DIR)) {
2147 unlink("$d/$f") if ($f ne '.' && $f ne '..');
2151 &flush_maildir_cachefile($_[0]);
2154 # get_maildir_cachefile(dir)
2155 # Returns the cache file for a maildir directory
2156 sub get_maildir_cachefile
2159 local $cd = $user_module_config_directory || $module_config_directory;
2160 local $sd = "$cd/maildircache";
2162 &make_dir($sd, 0755) || return undef;
2168 # flush_maildir_cachefile(dir)
2169 # Clear the on-disk and in-memory maildir caches
2170 sub flush_maildir_cachefile
2173 local $cachefile = &get_maildir_cachefile($dir);
2174 unlink($cachefile) if ($cachefile);
2175 delete($main::list_maildir_cache{$dir});
2176 delete($main::list_maildir_cache_time{$dir});
2179 # count_maildir(dir)
2180 # Returns the number of messages in a maildir directory
2183 local @files = &get_maildir_files($_[0]);
2184 return scalar(@files);
2187 # list_mhdir(file, [start], [end], [headersonly])
2188 # Returns a subset of mail from an MH format directory
2191 local ($start, $end, $f, $i, @rv);
2192 opendir(DIR, $_[0]);
2193 local @files = map { "$_[0]/$_" }
2195 grep { /^\d+$/ } readdir(DIR);
2197 if (!defined($_[1])) {
2202 $start = @files + $_[2] - 1;
2203 $end = @files + $_[1] - 1;
2204 $start = 0 if ($start < 0);
2209 $end = @files-1 if ($end >= @files);
2211 foreach $f (@files) {
2212 if ($i < $start || $i > $end) {
2213 # Skip files outside requested index range
2218 local $mail = &read_mail_file($f, $_[3]);
2219 $mail->{'idx'} = $i++;
2220 $mail->{'id'} = $f; # ID is message number
2221 $mail->{'id'} = substr($mail->{'id'}, length($_[0])+1);
2227 # idlist_mhdir(directory)
2228 # Returns a list of files in an MH directory, which are the IDs
2233 local @files = grep { /^\d+$/ } readdir(DIR);
2238 # get_mhdir_files(directory)
2239 # Returns a list of full paths to files in an MH directory
2243 return map { "$dir/$_" } &idlist_mhdir($dir);
2246 # select_mhdir(file, &ids, headersonly)
2247 # Returns a list of messages with the given indexes, from an mhdir directory
2250 local ($file, $ids, $headersonly) = @_;
2252 opendir(DIR, $file);
2253 local @files = map { "$file/$_" }
2255 grep { /^\d+$/ } readdir(DIR);
2257 foreach my $i (@$ids) {
2258 local $mail = &read_mail_file("$file/$i", $headersonly);
2260 $mail->{'idx'} = &indexof("$file/$i", @files);
2268 # search_mhdir(file|user, field, what)
2269 # Search for messages in an MH directory, and return the results
2272 return &advanced_search_mhdir($_[0], [ [ $_[1], $_[2] ] ], 1);
2275 # advanced_search_mhdir(file|user, &fields, andmode, &limit, [headersonly])
2276 # Search for messages in an MH directory, and return the results
2277 sub advanced_search_mhdir
2281 if ($_[3] && $_[3]->{'latest'}) {
2283 $max = -$_[3]->{'latest'};
2285 local $headersonly = $_[4] && !&matches_needs_body($_[1]);
2286 foreach $mail (&list_mhdir($_[0], $min, $max, $headersonly)) {
2287 push(@rv, $mail) if ($mail && &mail_matches($_[1], $_[2], $mail));
2292 # delete_mhdir(&mail, ...)
2293 # Delete messages from an MH directory
2298 unlink($m->{'file'});
2302 # modify_mhdir(&oldmail, &newmail, textonly)
2303 # Replaces a message in a maildir directory
2306 unlink($_[0]->{'file'});
2307 &send_mail($_[1], $_[0]->{'file'}, $_[2], 1);
2311 # Returns the maximum message ID in the directory
2315 opendir(DIR, $_[0]);
2316 foreach $f (readdir(DIR)) {
2317 $max = $f if ($f =~ /^\d+$/ && $f > $max);
2324 # Delete all messages in an MH format directory
2328 opendir(DIR, $_[0]);
2329 foreach $f (readdir(DIR)) {
2330 unlink("$_[0]/$f") if ($f =~ /^\d+$/);
2336 # Returns the number of messages in an MH directory
2339 opendir(DIR, $_[0]);
2340 local @files = grep { /^\d+$/ } readdir(DIR);
2342 return scalar(@files);
2345 # read_mail_file(file, [headersonly])
2346 # Read a single message from a file
2349 local (@headers, $mail);
2351 # Open and read the mail file
2352 open(MAIL, $_[0]) || return undef;
2353 $mail = &read_mail_fh(MAIL, 0, $_[1]);
2354 $mail->{'file'} = $_[0];
2356 local @st = stat($_[0]);
2357 $mail->{'size'} = $st[7];
2358 $mail->{'time'} = $st[9];
2360 # Set read flags based on the name
2361 if ($_[0] =~ /:2,([A-Za-z]*)$/) {
2362 local @flags = split(//, $1);
2363 $mail->{'read'} = &indexoflc("S", @flags) >= 0 ? 1 : 0;
2364 $mail->{'special'} = &indexoflc("F", @flags) >= 0 ? 1 : 0;
2365 $mail->{'replied'} = &indexoflc("R", @flags) >= 0 ? 1 : 0;
2366 $mail->{'flags'} = 1;
2372 # read_mail_fh(handle, [end-mode], [headersonly])
2373 # Reads an email message from the given file handle, either up to end of
2374 # the file, or a From line. End mode 0 = EOF, 1 = From without -,
2375 # 2 = From possibly with -
2378 local ($fh, $endmode, $headeronly) = @_;
2379 local (@headers, $mail);
2385 local $line = <$fh>;
2386 $mail->{'size'} += length($line);
2387 $line =~ s/\r|\n//g;
2388 last if ($line eq '');
2389 if ($line =~ /^(\S+):\s*(.*)/) {
2390 push(@headers, [ $1, $2 ]);
2391 $mail->{'rawheaders'} .= $line."\n";
2393 elsif ($line =~ /^\s+(.*)/) {
2394 $headers[$#headers]->[1] .= " ".$1 unless($#headers < 0);
2395 $mail->{'rawheaders'} .= $line."\n";
2397 elsif ($line =~ /^From\s+(\S+).*\d+/ &&
2398 ($1 ne '-' || $endmode == 2)) {
2399 $mail->{'fromline'} = $line;
2402 $mail->{'headers'} = \@headers;
2403 foreach $h (@headers) {
2404 $mail->{'header'}->{lc($h->[0])} = $h->[1];
2407 if (!$headersonly) {
2408 # Read the mail body
2409 if ($endmode == 0) {
2411 while(read($fh, $buf, 1024) > 0) {
2412 $mail->{'size'} += length($buf);
2413 $mail->{'body'} .= $buf;
2414 $lc = ($buf =~ tr/\n/\n/);
2420 # Tell next From line
2423 last if (!$line || $line =~ /^From\s+(\S+).*\d+\r?\n/ &&
2424 ($1 ne '-' || $endmode == 2));
2426 $mail->{'size'} += length($line);
2427 $mail->{'body'} .= $line;
2430 $mail->{'lines'} = $lnum;
2433 # Not reading the body, but we still need to search till the next
2434 # From: line in order to get the size
2437 last if (!$line || $line =~ /^From\s+(\S+).*\d+\r?\n/ &&
2438 ($1 ne '-' || $endmode == 2));
2440 $mail->{'size'} += length($line);
2442 $mail->{'lines'} = $lnum;
2447 # dash_mode(user|file)
2448 # Returns 1 if the messages in this folder are separated by lines like
2449 # From - instead of the usual From foo@bar.com
2452 open(DASH, &user_mail_file($_[0])) || return 0; # assume no
2453 local $line = <DASH>;
2455 return $line =~ /^From\s+(\S+).*\d/ && $1 eq '-';
2458 # mail_matches(&fields, andmode, &mail)
2459 # Returns 1 if some message matches a search
2464 foreach $f (@{$_[0]}) {
2465 local $field = $f->[0];
2466 local $what = $f->[1];
2467 local $neg = ($field =~ s/^\!//);
2468 if ($field eq 'body') {
2470 if (!$neg && $_[2]->{'body'} =~ /\Q$what\E/i ||
2471 $neg && $_[2]->{'body'} !~ /\Q$what\E/i);
2473 elsif ($field eq 'size') {
2475 if (!$neg && $_[2]->{'size'} > $what ||
2476 $neg && $_[2]->{'size'} < $what);
2478 elsif ($field eq 'headers') {
2479 local $headers = $_[2]->{'rawheaders'} ||
2480 join("", map { $_->[0].": ".$_->[1]."\n" }
2481 @{$_[2]->{'headers'}});
2483 if (!$neg && $headers =~ /\Q$what\E/i ||
2484 $neg && $headers !~ /\Q$what\E/i);
2486 elsif ($field eq 'all') {
2487 local $headers = $_[2]->{'rawheaders'} ||
2488 join("", map { $_->[0].": ".$_->[1]."\n" }
2489 @{$_[2]->{'headers'}});
2491 if (!$neg && ($_[2]->{'body'} =~ /\Q$what\E/i ||
2492 $headers =~ /\Q$what\E/i) ||
2493 $neg && ($_[2]->{'body'} !~ /\Q$what\E/i &&
2494 $headers !~ /\Q$what\E/i));
2496 elsif ($field eq 'status') {
2498 if (!$neg && $_[2]->{$field} =~ /\Q$what\E/i||
2499 $neg && $_[2]->{$field} !~ /\Q$what\E/i);
2503 if (!$neg && $_[2]->{'header'}->{$field} =~ /\Q$what\E/i||
2504 $neg && $_[2]->{'header'}->{$field} !~ /\Q$what\E/i);
2506 return 1 if ($count && !$_[1]);
2508 return $count == scalar(@{$_[0]});
2511 # search_fields(&fields)
2512 # Returns an array of headers/fields from a search
2516 foreach my $f (@{$_[0]}) {
2517 $f->[0] =~ /^\!?(.*)$/;
2520 return &unique(@rv);
2523 # matches_needs_body(&fields)
2524 # Returns 1 if a search needs to check the mail body
2525 sub matches_needs_body
2527 foreach my $f (@{$_[0]}) {
2528 return 1 if ($f->[0] eq 'body' || $f->[0] eq 'all');
2533 # parse_delivery_status(text)
2534 # Returns the fields from a message/delivery-status attachment
2535 sub parse_delivery_status
2537 local @lines = split(/[\r\n]+/, $_[0]);
2539 foreach $l (@lines) {
2540 if ($l =~ /^(\S+):\s*(.*)/) {
2547 # parse_mail_date(string)
2548 # Converts a mail Date: header into a unix time
2552 $str =~ s/^[, \t]+//;
2554 open(OLDSTDERR, ">&STDERR"); # suppress STDERR from Time::Local
2557 if ($str =~ /^(\S+),\s+(\d+)\s+(\S+)\s+(\d+)\s+(\d+):\s?(\d+):\s?(\d+)\s+(\S+)/) {
2558 # Format like Mon, 13 Dec 2004 14:40:41 +0100
2559 # or Mon, 13 Dec 2004 14:18:16 GMT
2560 # or Tue, 14 Sep 04 02:45:09 GMT
2561 local $tm = timegm($7, $6, $5, $2, &month_to_number($3),
2562 $4 < 50 ? $4+100 : $4 < 1000 ? $4 : $4-1900);
2564 if ($tz =~ /^(\-|\+)?\d+$/) {
2565 local $tz = int($tz);
2566 $tz = $tz/100 if ($tz >= 50 || $tz <= -50);
2571 elsif ($str =~ /^(\S+),\s+(\d+),?\s+(\S+)\s+(\d+)\s+(\d+):\s?(\d+):\s?(\d+)/) {
2572 # Format like Mon, 13 Dec 2004 14:40:41 or
2573 # Mon, 13, Dec 2004 14:40:41
2574 # No timezone, so assume local
2575 local $tm = timelocal($7, $6, $5, $2, &month_to_number($3),
2576 $4 < 50 ? $4+100 : $4 < 1000 ? $4 : $4-1900);
2579 elsif ($str =~ /^(\S+)\s+(\S+)\s+(\d+)\s+(\d+):(\d+):(\d+)\s+(\d+)/) {
2580 # Format like Tue Dec 7 12:58:52 2004
2581 local $tm = timelocal($6, $5, $4, $3, &month_to_number($2),
2582 $7 < 50 ? $7+100 : $7 < 1000 ? $7 : $7-1900);
2585 elsif ($str =~ /^(\S+)\s+(\S+)\s+(\d{1,2})\s+(\d+):(\d+):(\d+)/ &&
2586 &month_to_number($2)) {
2587 # Format like Tue Dec 7 12:58:52
2588 local @now = localtime(time());
2589 local $tm = timelocal($6, $5, $4, $3, &month_to_number($2),
2593 elsif ($str =~ /^(\S+)\s+(\S+)\s+(\d{1,2})\s+(\d+):(\d+)$/ &&
2594 defined(&month_to_number($2))) {
2595 # Format like Tue Dec 7 12:58
2596 local @now = localtime(time());
2597 local $tm = timelocal(0, $5, $4, $3, &month_to_number($2),
2601 elsif ($str =~ /^(\S+)\s+(\d{1,2})\s+(\d+):(\d+)$/ &&
2602 defined(&month_to_number($1))) {
2603 # Format like Dec 7 12:58
2604 local @now = localtime(time());
2605 local $tm = timelocal(0, $4, $3, $2, &month_to_number($1),
2609 elsif ($str =~ /^(\S+)\s+(\d+)\s+(\d+):(\d+):(\d+)\s+(\d+)\s+(\S+)/) {
2610 # Format like Dec 7 12:58:52 2004 GMT
2611 local $tm = timegm($5, $4, $3, $2, &month_to_number($1),
2612 $6 < 50 ? $6+100 : $6 < 1000 ? $6 : $6-1900);
2614 if ($tz =~ /^(\-|\+)?\d+$/) {
2616 $tz = $tz/100 if ($tz >= 50 || $tz <= -50);
2621 elsif ($str =~ /^(\d{4})\-(\d+)\-(\d+)\s+(\d+):(\d+)/) {
2622 # Format like 2004-12-07 12:53
2623 local $tm = timelocal(0, $4, $4, $3, $2-1,
2624 $1 < 50 ? $1+100 : $1 < 1000 ? $1 : $1-1900);
2627 elsif ($str =~ /^(\d+)\s+(\S+)\s+(\d+)\s+(\d+):(\d+):(\d+)\s+(\S+)/) {
2628 # Format like 30 Jun 2005 21:01:01 -0000
2629 local $tm = timegm($6, $5, $4, $1, &month_to_number($2),
2630 $3 < 50 ? $3+100 : $3 < 1000 ? $3 : $3-1900);
2632 if ($tz =~ /^(\-|\+)?\d+$/) {
2634 $tz = $tz/100 if ($tz >= 50 || $tz <= -50);
2639 elsif ($str =~ /^(\d+)\/(\S+)\/(\d+)\s+(\d+):(\d+)/) {
2640 # Format like 21/Feb/2008 24:13
2641 local $tm = timelocal(0, $5, $4, $1, &month_to_number($2),
2649 open(STDERR, ">&OLDSTDERR");
2652 #print STDERR "parsing of $str failed : $@\n";
2658 # send_text_mail(from, to, cc, subject, body, [smtp-server])
2659 # A convenience function for sending a email with just a text body
2662 local ($from, $to, $cc, $subject, $body, $smtp) = @_;
2663 local $cs = &get_charset();
2664 local $attach = $body =~ /[\177-\377]/ ?
2665 { 'headers' => [ [ 'Content-Type', 'text/plain; charset='.$cs ],
2666 [ 'Content-Transfer-Encoding', 'quoted-printable' ] ],
2667 'data' => "ed_encode($body) } :
2668 { 'headers' => [ [ 'Content-type', 'text/plain' ] ],
2669 'data' => &entities_to_ascii($body) };
2670 local $mail = { 'headers' =>
2671 [ [ 'From', $from ],
2674 [ 'Subject', $subject ] ],
2675 'attach' => [ $attach ] };
2676 return &send_mail($mail, undef, 1, 0, $smtp);
2679 # make_from_line(address, [time])
2680 # Returns a From line for mbox emails, based on the current time
2683 local ($addr, $t) = @_;
2685 &clear_time_locale();
2686 local $rv = "From $addr ".strftime("%a %b %e %H:%M:%S %Y", localtime($t));
2687 &reset_time_locale();
2693 # Deprecated - does nothing
2696 # add_mailer_ip_headers(&headers)
2697 # Add X-Mailer and X-Originating-IP headers, if enabled
2698 sub add_mailer_ip_headers
2700 local ($headers) = @_;
2701 if (!$config{'no_orig_ip'}) {
2702 push(@$headers, [ 'X-Originating-IP', $ENV{'REMOTE_ADDR'} ]);
2704 if (!$config{'no_mailer'}) {
2705 push(@$headers, [ 'X-Mailer', ucfirst(&get_product_name())." ".
2706 &get_webmin_version() ]);