iam.tj Git - webmin.git/blob - mailboxes/boxes-lib.pl

1 # boxes-lib.pl

2 # Functions to parsing user mail files

3

4 use POSIX;

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'} ||

9 $config{'date_tz'};

10 strftime('%H:%M', localtime(time()));

11 }

12 use Time::Local;

13

14 $dbm_index_min = 1000000;

15 $dbm_index_version = 3;

16

17 # list_mails(user|file, [start], [end])

18 # Returns a subset of mail from a mbox format file

19 sub list_mails

20 {

21 local (@rv, $h, $done);

22 my %index;

23 &build_dbm_index($_[0], \%index);

24 local ($start, $end);

25 local $isize = $index{'mailcount'};

26 if (@_ == 1 || !defined($_[1]) && !defined($_[2])) {

27 $start = 0; $end = $isize-1;

28 }

29 elsif ($_[2] < 0) {

30 $start = $isize+$_[2]-1; $end = $isize+$_[1]-1;

31 $start = $start<0 ? 0 : $start;

32 }

33 else {

34 $start = $_[1]; $end = $_[2];

35 $end = $isize-1 if ($end >= $isize);

36 }

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});

44 local $pos = $idx[0];

45 local $startline = $idx[1];

46 seek(MAIL, $pos, 0);

47

48 # Read the mail

49 local $mail = &read_mail_fh(MAIL, $dash ? 2 : 1, 0);

50 $mail->{'line'} = $startline;

51 $mail->{'eline'} = $startline + $mail->{'lines'} - 1;

52 $mail->{'idx'} = $i;

53 # ID is position in file and message ID

54 $mail->{'id'} = $pos." ".$i." ".$startline." ".

55 substr($mail->{'header'}->{'message-id'}, 0, 255);

56 $rv[$i] = $mail;

57 }

58 return @rv;

59 }

60

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

64 # if valid.

65 sub select_mails

66 {

67 local ($file, $ids, $headersonly) = @_;

68 local @rv;

69

70 local (@rv);

71 my %index;

72 local $gotindex;

73

74 local $umf = &user_mail_file($file);

75 local $dash = &dash_mode($umf);

76 open(MAIL, $umf);

77 foreach my $i (@$ids) {

78 local ($pos, $idx, $startline, $wantmid) = split(/ /, $i);

79

80 # Go to where the mail is supposed to be, and check if any starts there

81 seek(MAIL, $pos, 0);

82 local $ll = <MAIL>;

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";

86 if (!$fromok) {

87 # Oh noes! Need to find it

88 if (!$gotindex++) {

89 &build_dbm_index($file, \%index);

90 }

91 $pos = undef;

92 while(my ($k, $v) = each %index) {

93 if (int($k) eq $k) {

94 my ($p, $line, $subject, $from, $mid)=

95 split(/\0/, $v);

96 if ($mid eq $wantmid) {

97 # Found it!

98 $pos = $p;

99 $idx = $k;

100 $startline = $line;

101 last;

102 }

103 }

104 }

105 }

106

107 if (defined($pos)) {

108 # Now we can read

109 seek(MAIL, $pos, 0);

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";

115 push(@rv, $mail);

116 }

117 else {

118 push(@rv, undef); # Mail is gone?

119 }

120 }

121 close(MAIL);

122 return @rv;

123 }

124

125 # idlist_mails(user|file)

126 # Returns a list of IDs in some mbox

127 sub idlist_mails

128 {

129 my %index;

130 local $idlist = &build_dbm_index($_[0], \%index);

131 return @$idlist;

132 }

133

134 # search_mail(user, field, match)

135 # Returns an array of messages matching some search

136 sub search_mail

137 {

138 return &advanced_search_mail($_[0], [ [ $_[1], $_[2] ] ], 1);

139 }

140

141 # advanced_search_mail(user|file, &fields, andmode, [&limits], [headersonly])

142 # Returns an array of messages matching some search

143 sub advanced_search_mail

144 {

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?

149 local ($min, $max);

150

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);

154

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]}));

159

160 $min = 0;

161 $max = $index{'mailcount'}-1;

162 if ($_[3] && $_[3]->{'latest'}) {

163 $min = $max - $_[3]->{'latest'};

164 }

165

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);

176 }

177 $possible_certain = $alldbm;

178 }

179 else {

180 # None of the DBM fields are in the search .. have to scan all

181 @possible = ($min .. $max);

182 }

183

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];

192 seek(MAIL, $pos, 0);

193

194 # Read the mail

195 local $mail = &read_mail_fh(MAIL, $dash ? 2 : 1, $headersonly);

196 $mail->{'line'} = $startline;

197 $mail->{'eline'} = $startline + $mail->{'lines'} - 1;

198 $mail->{'idx'} = $i;

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));

203 }

204 return @rv;

205 }

206

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

215 sub build_dbm_index

216 {

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);

222

223 # Read file of IDs

224 local $idsfile = $ifile.".ids";

225 local @ids;

226 local $idschanged;

227 if (open(IDSFILE, $idsfile)) {

228 @ids = <IDSFILE>;

229 chop(@ids);

230 close(IDSFILE);

231 }

232

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";

236 @ids = ( );

237 while(my ($k, $v) = each %$index) {

238 if ($k eq int($k) && $k < $index->{'mailcount'}) {

239 local ($pos, $line, $subject, $sender, $mid) =

240 split(/\0/, $v);

241 $ids[$k] = $pos." ".$k." ".$line." ".$mid;

242 }

243 elsif ($k >= $index->{'mailcount'}) {

244 # Old crap that is off the end

245 delete($index->{$k});

246 }

247 }

248 $index->{'mailcount'} = scalar(@ids); # Now known for sure

249 $idschanged = 1;

250 }

251

252 if (!@st ||

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

258 local $fromok = 1;

259 local ($ll, @idx);

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

264 open(MAIL, $umf);

265 }

266 else {

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,

270 # or re-written.

271 local $il = $index->{'mailcount'}-1;

272 local $i;

273 for($i=($il>100 ? 100 : $il); $i>=0; $i--) {

274 @idx = split(/\0/, $index->{$il-$i});

275 seek(MAIL, $idx[0], 0);

276 $ll = <MAIL>;

277 $fromok = 0 if ($ll !~ /^From\s+(\S+).*\d+\r?\n/ ||

278 ($1 eq '-' && !$dash));

279 }

280 }

281 else {

282 $fromok = 0; # No mail file yet

283 }

284 }

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);

291 $lnum = $idx[1] + 1;

292 $istart = $index->{'mailcount'};

293 }

294 else {

295 # Mail file has changed in some other way ... do a rebuild

296 # of the whole index

297 print DEBUG "totally re-indexing\n";

298 $istart = 0;

299 $pos = 0;

300 $lnum = 0;

301 seek(MAIL, 0, 0);

302 @ids = ( );

303 $idschanged = 1;

304 %$index = ( );

305 }

306 local ($doingheaders, @nidx);

307 while(<MAIL>) {

308 if (/^From\s+(\S+).*\d+\r?\n/ && ($1 ne '-' || $dash)) {

309 @nidx = ( $pos, $lnum );

310 $idschanged = 1;

311 push(@ids, $pos." ".$istart." ".$lnum);

312 $index->{$istart++} = join("\0", @nidx);

313 $doingheaders = 1;

314 }

315 elsif ($_ eq "\n" || $_ eq "\r\n") {

316 $doingheaders = 0;

317 }

318 elsif ($doingheaders && /^From:\s*(.{0,255})/i) {

319 $nidx[2] = $1;

320 $index->{$istart-1} = join("\0", @nidx);

321 }

322 elsif ($doingheaders && /^Subject:\s*(.{0,255})/i) {

323 $nidx[3] = $1;

324 $index->{$istart-1} = join("\0", @nidx);

325 }

326 elsif ($doingheaders && /^Message-ID:\s*(.{0,255})/i) {

327 $nidx[4] = $1;

328 $index->{$istart-1} = join("\0", @nidx);

329 $ids[$#ids] .= " ".$1;

330 }

331 $pos += length($_);

332 $lnum++;

333 }

334 close(MAIL);

335 $index->{'lastchange'} = time();

336 $index->{'lastsize'} = $st[7];

337 $index->{'mailcount'} = $istart;

338 $index->{'version'} = $dbm_index_version;

339 }

340

341 # Write out IDs file, if needed

342 if ($idschanged) {

343 open(IDSFILE, ">$idsfile");

344 foreach my $id (@ids) {

345 print IDSFILE $id,"\n";

346 }

347 close(IDSFILE);

348 }

349

350 return \@ids;

351 }

352

353 # has_dbm_index(user|file)

354 # Returns 1 if a DBM index exists for some user or file

355 sub has_dbm_index

356 {

357 local $ifile = &user_index_file($_[0]);

358 foreach my $ext (".dir", ".pag", ".db") {

359 return 1 if (-r $ifile.$ext);

360 }

361 return 0;

362 }

363

364 # empty_mail(user|file)

365 # Truncate a mail file to nothing

366 sub empty_mail

367 {

368 local $umf = &user_mail_file($_[0]);

369 local $ifile = &user_index_file($_[0]);

370 open(TRUNC, ">$umf");

371 close(TRUNC);

372

373 # Set index size to 0

374 local %index;

375 dbmopen(%index, $ifile, 0600);

376 $index{'mailcount'} = 0;

377 $index{'lastchange'} = time();

378 dbmclose(%index);

379 }

380

381 # count_mail(user|file)

382 # Returns the number of messages in some mail file

383 sub count_mail

384 {

385 my %index;

386 &build_dbm_index($_[0], \%index);

387 return $index{'mailcount'};

388 }

389

390 # parse_mail(&mail, [&parent], [savebody], [keep-cr])

391 # Extracts the attachments from the mail body

392 sub parse_mail

393 {

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'});

403 local $l;

404 local $max = @lines;

405 while($l < $max && $lines[$l++] ne $bound) {

406 # skip to first boundary

407 }

408 while(1) {

409 # read attachment headers

410 local (@headers, $attach);

411 while($lines[$l]) {

412 $attach->{'raw'} .= $lines[$l]."\n";

413 $attach->{'rawheaders'} .= $lines[$l]."\n";

414 if ($lines[$l] =~ /^(\S+):\s*(.*)/) {

415 push(@headers, [ $1, $2 ]);

416 }

417 elsif ($lines[$l] =~ /^\s+(.*)/) {

418 $headers[$#headers]->[1] .= " ".$1

419 unless($#headers < 0);

420 }

421 $l++;

422 }

423 $attach->{'raw'} .= $lines[$l]."\n";

424 $l++;

425 $attach->{'headers'} = \@headers;

426 foreach $h (@headers) {

427 $attach->{'header'}->{lc($h->[0])} = $h->[1];

428 }

429 if ($attach->{'header'}->{'content-type'} =~ /^([^;\s]+)/) {

430 $attach->{'type'} = lc($1);

431 }

432 else {

433 $attach->{'type'} = 'text/plain';

434 }

435 if ($attach->{'header'}->{'content-disposition'} =~

436 /filename\s*=\s*"([^"]+)"/i) {

437 $attach->{'filename'} = $1;

438 }

439 elsif ($attach->{'header'}->{'content-disposition'} =~

440 /filename\s*=\s*([^;\s]+)/i) {

441 $attach->{'filename'} = $1;

442 }

443 elsif ($attach->{'header'}->{'content-type'} =~

444 /name\s*=\s*"([^"]+)"/i) {

445 $attach->{'filename'} = $1;

446 }

447 elsif ($attach->{'header'}->{'content-type'} =~

448 /name\s*=\s*([^;\s]+)/i) {

449 $attach->{'filename'} = $1;

450 }

451

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";

456 $l++;

457 }

458 $attach->{'data'} =~ s/\n\n$/\n/; # Lose trailing blank line

459 $attach->{'raw'} =~ s/\n\n$/\n/;

460

461 # decode if necessary

462 if (lc($attach->{'header'}->{'content-transfer-encoding'}) eq

463 'base64') {

464 # Standard base64 encoded attachment

465 $attach->{'data'} = &b64decode($attach->{'data'});

466 }

467 elsif (lc($attach->{'header'}->{'content-transfer-encoding'}) eq

468 'x-uue') {

469 # UUencoded attachment

470 $attach->{'data'} = &uudecode($attach->{'data'});

471 }

472 elsif (lc($attach->{'header'}->{'content-transfer-encoding'}) eq

473 'quoted-printable') {

474 # Quoted-printable text attachment

475 $attach->{'data'} = &quoted_decode($attach->{'data'});

476 }

477 elsif (lc($attach->{'type'}) eq 'application/mac-binhex40' && &has_command("hexbin")) {

478 # Macintosh binhex encoded attachment

479 local $temp = &transname();

480 mkdir($temp, 0700);

481 open(HEXBIN, "| (cd $temp ; hexbin -n attach -d 2>/dev/null)");

482 print HEXBIN $attach->{'data'};

483 close(HEXBIN);

484 if (!$?) {

485 open(HEXBIN, "$temp/attach.data");

486 local $/ = undef;

487 $attach->{'data'} = <HEXBIN>;

488 close(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 ] ];

493 }

494 unlink("$temp/attach.data");

495 rmdir($temp);

496 }

497

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 ..

503 # expand them.

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'}});

511 }

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";

519 }

520 else {

521 # Can actually decode

522 local $tempfile = &transname();

523 open(TEMPFILE, ">$tempfile");

524 print TEMPFILE $attach->{'data'};

525 close(TEMPFILE);

526 local $tempdir = &transname();

527 mkdir($tempdir, 0700);

528 if ($opentnef) {

529 system("$opentnef -d $tempdir -i $tempfile >/dev/null 2>&1");

530 }

531 else {

532 system("$tnef -C $tempdir -f $tempfile >/dev/null 2>&1");

533 }

534 pop(@attach); # lose winmail.dat

535 opendir(DIR, $tempdir);

536 while($f = readdir(DIR)) {

537 next if ($f eq '.' || $f eq '..');

538 local $data;

539 open(FILE, "$tempdir/$f");

540 while(<FILE>) {

541 $data .= $_;

542 }

543 close(FILE);

544 local $ct = &guess_mime_type($f);

545 push(@attach,

546 { 'type' => $ct,

547 'idx' => scalar(@attach),

548 'header' =>

549 { 'content-type' => $ct },

550 'headers' =>

551 [ [ 'Content-Type', $ct ] ],

552 'filename' => $f,

553 'data' => $data });

554 }

555 closedir(DIR);

556 unlink(glob("$tempdir/*"), $tempfile);

557 rmdir($tempdir);

558 }

559 }

560 last if ($l >= $max || $lines[$l] eq "$bound--");

561 $l++;

562 }

563 $_[0]->{'attach'} = \@attach;

564 }

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'}}),

573 'parent' => $_[1],

574 'filename' => $2 };

575 push(@{$_[0]->{'attach'}}, $attach);

576 }

577 elsif ($l =~ /^end/ && $attach) {

578 $attach = undef;

579 }

580 elsif ($attach) {

581 $attach->{'data'} .= unpack("u", $l);

582 }

583 else {

584 $rest .= $l."\n";

585 }

586 }

587 if ($rest =~ /\S/) {

588 # Some leftover text

589 push(@{$_[0]->{'attach'}},

590 { 'type' => "text/plain",

591 'idx' => scalar(@{$_[0]->{'attach'}}),

592 'parent' => $_[1],

593 'data' => $rest });

594 }

595 }

596 elsif (lc($_[0]->{'header'}->{'content-transfer-encoding'}) eq 'base64') {

597 # Signed body section

598 $ct =~ s/;.*$//;

599 $_[0]->{'attach'} = [ { 'type' => lc($ct),

600 'idx' => 0,

601 'parent' => $_[1],

602 'data' => &b64decode($_[0]->{'body'}) } ];

603 }

604 elsif (lc($_[0]->{'header'}->{'content-type'}) eq 'x-sun-attachment') {

605 # Sun attachment format, which can contain several sections

606 local $sun;

607 foreach $sun (split(/----------/, $_[0]->{'body'})) {

608 local ($headers, $rest) = split(/\r?\n\r?\n/, $sun, 2);

609 local $attach = { 'idx' => scalar(@{$_[0]->{'attach'}}),

610 'parent' => $_[1],

611 'data' => $rest };

612 if ($headers =~ /X-Sun-Data-Name:\s*(\S+)/) {

613 $attach->{'filename'} = $1;

614 }

615 if ($headers =~ /X-Sun-Data-Type:\s*(\S+)/) {

616 local $st = $1;

617 $attach->{'type'} = $st eq "text" ? "text/plain" :

618 $st eq "html" ? "text/html" :

619 $st =~ /\// ? $st : "application/octet-stream";

620 }

621 elsif ($attach->{'filename'}) {

622 $attach->{'type'} =

623 &guess_mime_type($attach->{'filename'});

624 }

625 else {

626 $attach->{'type'} = "text/plain"; # fallback

627 }

628 push(@{$_[0]->{'attach'}}, $attach);

629 }

630 }

631 else {

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'});

638 }

639 elsif (lc($_[0]->{'header'}->{'content-transfer-encoding'}) eq

640 'quoted-printable') {

641 $body = &quoted_decode($_[0]->{'body'});

642 }

643 else {

644 $body = $_[0]->{'body'};

645 }

646 if ($body =~ /\S/) {

647 $_[0]->{'attach'} = [ { 'type' => lc($type),

648 'idx' => 0,

649 'parent' => $_[1],

650 'data' => $body } ];

651 }

652 else {

653 # Body is completely empty

654 $_[0]->{'attach'} = [ ];

655 }

656 }

657 delete($_[0]->{'body'}) if (!$_[2]);

658 }

659

660 # delete_mail(user|file, &mail, ...)

661 # Delete mail messages from a user by copying the file and rebuilding the index

662 sub delete_mail

663 {

664 # Validate messages

665 local @m = sort { $a->{'line'} <=> $b->{'line'} } @_[1..@_-1];

666 foreach my $m (@m) {

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");

671 }

672

673 local $i = 0;

674 local $f = &user_mail_file($_[0]);

675 local $ifile = &user_index_file($_[0]);

676 local $lnum = 0;

677 local (%dline, @fline);

678 local ($dpos = 0, $dlnum = 0);

679 local (@index, %index);

680 &build_dbm_index($_[0], \%index);

681

682 local $tmpf = $< == 0 ? "$f.del" :

683 $_[0] =~ /^\/.*\/([^\/]+)$/ ?

684 "$user_module_config_directory/$1.del" :

685 "$user_module_config_directory/$_[0].del";

686 if (-l $f) {

687 $f = &resolve_links($f);

688 }

689 open(SOURCE, $f) || &error("Read failed : $!");

690 open(DEST, ">$tmpf") || &error("Open of $tmpf failed : $!");

691 while(<SOURCE>) {

692 if ($i >= @m || $lnum < $m[$i]->{'line'}) {

693 # Within a range that we want to preserve

694 $dpos += length($_);

695 $dlnum++;

696 local $w = (print DEST $_);

697 if (!$w) {

698 local $e = "$!";

699 close(DEST);

700 close(SOURCE);

701 unlink($tmpf);

702 &error("Write to $tmpf failed : $e");

703 }

704 }

705 elsif (!$fline[$i]) {

706 # Start line of a message to delete

707 if (!/^From\s/) {

708 # Not actually a message! Fail now

709 close(DEST);

710 close(SOURCE);

711 unlink($tmpf);

712 &error("Index on $f is corrupt - did not find expected message start at line $lnum");

713 }

714 $fline[$i] = 1;

715 }

716 elsif ($lnum == $m[$i]->{'eline'}) {

717 # End line of the current message to delete

718 $dline{$m[$i]->{'line'}}++;

719 $i++;

720 }

721 $lnum++;

722 }

723 close(SOURCE);

724 close(DEST) || &error("Write to $tmpf failed : $?");

725 local @st = stat($f);

726 unlink($f) if ($< == 0);

727

728 # Force a total index re-build (XXX lazy!)

729 $index{'mailcount'} = $in{'lastchange'} = 0;

730 dbmclose(%index);

731

732 if ($< == 0) {

733 rename($tmpf, $f);

734 }

735 else {

736 system("cat ".quotemeta($tmpf)." > ".quotemeta($f).

737 " && rm -f ".quotemeta($tmpf));

738 }

739 chown($st[4], $st[5], $f);

740 chmod($st[2], $f);

741 }

742

743 # modify_mail(user|file, old, new, textonly)

744 # Modify one email message in a mailbox by copying the file and rebuilding

745 # the index.

746 sub modify_mail

747 {

748 local $f = &user_mail_file($_[0]);

749 local $ifile = &user_index_file($_[0]);

750 local $lnum = 0;

751 local ($sizediff, $linesdiff);

752 local %index;

753 &build_dbm_index($_[0], \%index);

754

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";

760 if (-l $f) {

761 $f = &resolve_links($f);

762 }

763 open(SOURCE, $f);

764 open(DEST, ">$tmpf");

765 while(<SOURCE>) {

766 if ($lnum < $_[1]->{'line'} || $lnum > $_[1]->{'eline'}) {

767 # before or after the message to change

768 local $w = (print DEST $_);

769 if (!$w) {

770 local $e = "$?";

771 close(DEST);

772 close(SOURCE);

773 unlink($tmpf);

774 &error("Write to $tmpf failed : $e");

775 }

776 }

777 elsif ($lnum == $_[1]->{'line'}) {

778 # found start of message to change .. put in the new one

779 close(DEST);

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");

787 }

788 $lnum++;

789 }

790 close(SOURCE);

791 close(DEST) || &error("Write failed : $!");

792

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);

800 }

801 }

802 $index{'lastchange'} = time();

803 local @st = stat($f);

804 unlink($f);

805 if ($< == 0) {

806 rename($tmpf, $f);

807 }

808 else {

809 system("cat $tmpf >$f && rm -f $tmpf");

810 }

811 chown($st[4], $st[5], $f);

812 chmod($st[2], $f);

813 }

814

815 # send_mail(&mail, [file], [textonly], [nocr], [smtp-server],

816 # [smtp-user], [smtp-pass], [smtp-auth-mode],

817 # [&notify-flags], [port])

818 # Send out some email message or append it to a file.

819 # Returns the number of lines written.

820 sub send_mail

821 {

822 return 0 if (&is_readonly_mode());

823 local (%header, $h);

824 local $lnum = 0;

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];

830 }

831

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();

839

840 # Build list of destination email addresses

841 my @dests;

842 foreach my $f ("to", "cc", "bcc") {

843 if ($header{$f}) {

844 push(@dests, &address_parts($header{$f}));

845 }

846 }

847 my $qdests = join(" ", map { quotemeta($_) } @dests);

848

849 local @from = &address_parts($header{'from'});

850 local $fromaddr;

851 if (@from && $from[0] =~ /\S/) {

852 $fromaddr = $from[0];

853 }

854 else {

855 local @uinfo = getpwuid($<);

856 $fromaddr = $uinfo[0] || "nobody";

857 $fromaddr .= '@'.&get_system_hostname();

858 }

859 local $esmtp = $_[8] ? 1 : 0;

860 if ($_[1]) {

861 # Just append the email to a file using mbox format

862 open(MAIL, ">>$_[1]") || &error("Write failed : $!");

863 $lnum++;

864 print MAIL $_[0]->{'fromline'} ? $_[0]->{'fromline'}.$eol :

865 &make_from_line($fromaddr).$eol;

866 }

867 elsif ($sm) {

868 # Connect to SMTP server

869 &open_socket($sm, $port, MAIL);

870 &smtp_command(MAIL);

871 if ($esmtp) {

872 &smtp_command(MAIL, "ehlo ".&get_system_hostname()."\r\n");

873 }

874 else {

875 &smtp_command(MAIL, "helo ".&get_system_hostname()."\r\n");

876 }

877

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";

883 if ($user) {

884 # Send authentication commands

885 eval "use Authen::SASL";

886 if ($@) {

887 &error("Perl module <tt>Authen::SASL</tt> is needed for SMTP authentication");

888 }

889 my $sasl = Authen::SASL->new('mechanism' => uc($auth),

890 'callback' => {

891 'auth' => $user,

892 'user' => $user,

893 'pass' => $pass } );

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

899 $extra = $2;

900 local $initial = $conn->client_start();

901 local $auth_ok;

902 if ($initial) {

903 local $enc = &encode_base64($initial);

904 $enc =~ s/\r|\n//g;

905 $arv = &smtp_command(MAIL, "$enc\r\n", 1);

906 if ($arv =~ /^(\d+)\s+(.*)/) {

907 if ($1 == 235) {

908 $auth_ok = 1;

909 }

910 else {

911 &error("Unknown SMTP authentication response : $arv");

912 }

913 }

914 $extra = $2;

915 }

916 while(!$auth_ok) {

917 local $message = &decode_base64($extra);

918 local $return = $conn->client_step($message);

919 local $enc = &encode_base64($return);

920 $enc =~ s/\r|\n//g;

921 $arv = &smtp_command(MAIL, "$enc\r\n", 1);

922 if ($arv =~ /^(\d+)\s+(.*)/) {

923 if ($1 == 235) {

924 $auth_ok = 1;

925 }

926 elsif ($1 == 535) {

927 &error("SMTP authentication failed : $arv");

928 }

929 $extra = $2;

930 }

931 else {

932 &error("Unknown SMTP authentication response : $arv");

933 }

934 }

935 }

936 }

937

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");

942 }

943 &smtp_command(MAIL, "data\r\n");

944 }

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");

950 }

951 elsif ($config{'qmail_dir'}) {

952 # Start qmail-inject

953 open(MAIL, "| $config{'qmail_dir'}/bin/qmail-inject");

954 }

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");

961 }

962 else {

963 # Start sendmail

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");

967 }

968 local $ctype = "multipart/mixed";

969 local $msg_id;

970 foreach $h (@{$_[0]->{'headers'}}) {

971 if (defined($_[0]->{'body'}) || $_[2]) {

972 print MAIL $h->[0],": ",$h->[1],$eol;

973 $lnum++;

974 }

975 else {

976 if ($h->[0] !~ /^(MIME-Version|Content-Type)$/i) {

977 print MAIL $h->[0],": ",$h->[1],$eol;

978 $lnum++;

979 }

980 elsif (lc($h->[0]) eq 'content-type') {

981 $ctype = $h->[1];

982 }

983 }

984 if (lc($h->[0]) eq 'message-id') {

985 $msg_id++;

986 }

987 }

988 if (!$msg_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;

994 }

995

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") {

1003 $ftype = $h->[1];

1004 }

1005 if (lc($h->[0]) eq "content-transfer-encoding") {

1006 $fenc = $h->[1];

1007 }

1008 }

1009 }

1010

1011 if (defined($_[0]->{'body'})) {

1012 # Use original mail body

1013 print MAIL $eol;

1014 $lnum++;

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/);

1021 }

1022 elsif (!@{$_[0]->{'attach'}}) {

1023 # No content, so just send empty email

1024 print MAIL "Content-Type: text/plain",$eol;

1025 print MAIL $eol;

1026 $lnum += 2;

1027 }

1028 elsif (!$_[2] || $ftype !~ /text\/plain/i ||

1029 $fenc =~ /quoted-printable|base64/) {

1030 # Sending MIME-encoded email

1031 if ($ctype !~ /multipart\/report/i) {

1032 $ctype =~ s/;.*$//;

1033 }

1034 print MAIL "MIME-Version: 1.0",$eol;

1035 local $bound = "bound".time();

1036 print MAIL "Content-Type: $ctype; boundary=\"$bound\"",$eol;

1037 print MAIL $eol;

1038 $lnum += 3;

1039

1040 # Send attachments

1041 print MAIL "This is a multi-part message in MIME format.",$eol;

1042 $lnum++;

1043 foreach $a (@{$_[0]->{'attach'}}) {

1044 print MAIL $eol;

1045 print MAIL "--",$bound,$eol;

1046 $lnum += 2;

1047 local $enc;

1048 foreach $h (@{$a->{'headers'}}) {

1049 print MAIL $h->[0],": ",$h->[1],$eol;

1050 $enc = $h->[1]

1051 if (lc($h->[0]) eq 'content-transfer-encoding');

1052 $lnum++;

1053 }

1054 print MAIL $eol;

1055 $lnum++;

1056 if (lc($enc) eq 'base64') {

1057 local $enc = &encode_base64($a->{'data'});

1058 $enc =~ s/\r//g;

1059 $enc =~ s/\n/$eol/g;

1060 print MAIL $enc;

1061 $lnum += ($enc =~ tr/\n/\n/);

1062 }

1063 else {

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$/) {

1070 print MAIL $eol;

1071 $lnum++;

1072 }

1073 }

1074 }

1075 print MAIL $eol;

1076 (print MAIL "--",$bound,"--",$eol) || &error("Write failed : $!");

1077 print MAIL $eol;

1078 $lnum += 3;

1079 }

1080 else {

1081 # Sending text-only mail from first attachment

1082 local $a = $_[0]->{'attach'}->[0];

1083 print MAIL $eol;

1084 $lnum++;

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$/) {

1090 print MAIL $eol;

1091 $lnum++;

1092 }

1093 }

1094 if ($sm && !$_[1]) {

1095 &smtp_command(MAIL, ".$eol");

1096 &smtp_command(MAIL, "quit$eol");

1097 }

1098 if (!close(MAIL)) {

1099 # Only bother to report an error on close if writing to a file

1100 if ($_[1]) {

1101 &error("Write failed : $!");

1102 }

1103 }

1104 return $lnum;

1105 }

1106

1107 # unparse_mail(&attachments, eol, boundary)

1108 # Convert an array of attachments into MIME format, and return them as an

1109 # array of lines.

1110 sub unparse_mail

1111 {

1112 local ($attach, $eol, $bound) = @_;

1113 local @rv;

1114 foreach my $a (@$attach) {

1115 push(@rv, $eol);

1116 push(@rv, "--".$bound.$eol);

1117 local $enc;

1118 foreach my $h (@{$a->{'headers'}}) {

1119 push(@rv, $h->[0].": ".$h->[1].$eol);

1120 $enc = $h->[1]

1121 if (lc($h->[0]) eq 'content-transfer-encoding');

1122 }

1123 push(@rv, $eol);

1124 if (lc($enc) eq 'base64') {

1125 local $enc = &encode_base64($a->{'data'});

1126 $enc =~ s/\r//g;

1127 foreach my $l (split(/\n/, $enc)) {

1128 push(@rv, $l.$eol);

1129 }

1130 }

1131 else {

1132 $a->{'data'} =~ s/\r//g;

1133 $a->{'data'} =~ s/\n\.\n/\n\. \n/g;

1134 foreach my $l (split(/\n/, $a->{'data'})) {

1135 push(@rv, $l.$eol);

1136 }

1137 }

1138 }

1139 push(@rv, $eol);

1140 push(@rv, "--".$bound."--".$eol);

1141 push(@rv, $eol);

1142 return @rv;

1143 }

1144

1145 # mail_size(&mail, [textonly])

1146 # Returns the size of an email message in bytes

1147 sub mail_size

1148 {

1149 local ($mail, $textonly) = @_;

1150 local $temp = &transname();

1151 &send_mail($mail, $temp, $textonly);

1152 local @st = stat($temp);

1153 unlink($temp);

1154 return $st[7];

1155 }

1156

1157 # b64decode(string)

1158 # Converts a string from base64 format to normal

1159 sub b64decode

1160 {

1161 local($str) = $_[0];

1162 local($res);

1163 $str =~ tr|A-Za-z0-9+=/||cd;

1164 $str =~ s/=+$//;

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 );

1169 }

1170 return $res;

1171 }

1172

1173 # can_read_mail(user)

1174 sub can_read_mail

1175 {

1176 return 1 if ($_[0] && $access{'sent'} eq $_[0]);

1177 local @u = getpwnam($_[0]);

1178 return 0 if (!@u);

1179 return 0 if ($_[0] =~ /\.\./);

1180 return 0 if ($access{'mmode'} == 0);

1181 return 1 if ($access{'mmode'} == 1);

1182 local $u;

1183 if ($access{'mmode'} == 2) {

1184 foreach $u (split(/\s+/, $access{'musers'})) {

1185 return 1 if ($u eq $_[0]);

1186 }

1187 return 0;

1188 }

1189 elsif ($access{'mmode'} == 4) {

1190 return 1 if ($_[0] eq $remote_user);

1191 }

1192 elsif ($access{'mmode'} == 5) {

1193 return $u[3] eq $access{'musers'};

1194 }

1195 elsif ($access{'mmode'} == 3) {

1196 foreach $u (split(/\s+/, $access{'musers'})) {

1197 return 0 if ($u eq $_[0]);

1198 }

1199 return 1;

1200 }

1201 elsif ($access{'mmode'} == 6) {

1202 return ($_[0] =~ /^$access{'musers'}$/);

1203 }

1204 elsif ($access{'mmode'} == 7) {

1205 return (!$access{'musers'} || $u[2] >= $access{'musers'}) &&

1206 (!$access{'musers2'} || $u[2] <= $access{'musers2'});

1207 }

1208 return 0; # can't happen!

1209 }

1210

1211 # from_hostname()

1212 sub from_hostname

1213 {

1214 local ($d, $masq);

1215 local $conf = &get_sendmailcf();

1216 foreach $d (&find_type("D", $conf)) {

1217 if ($d->{'value'} =~ /^M\s*(\S*)/) { $masq = $1; }

1218 }

1219 return $masq ? $masq : &get_system_hostname();

1220 }

1221

1222 # mail_from_queue(qfile, [dfile|"auto"])

1223 # Reads a message from the Sendmail mail queue

1224 sub mail_from_queue

1225 {

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/;

1232 }

1233 elsif ($_[1]) {

1234 $mail->{'dfile'} = $_[1];

1235 }

1236 $mail->{'lfile'} = $_[0];

1237 $mail->{'lfile'} =~ s/\/(qf|hf|Qf)/\/xf/;

1238 local $_;

1239 local @headers;

1240 open(QF, $_[0]) || return undef;

1241 while(<QF>) {

1242 s/\r|\n//g;

1243 if (/^M(.*)/) {

1244 $mail->{'status'} = $1;

1245 }

1246 elsif (/^H\?[^\?]*\?(\S+):\s+(.*)/ || /^H(\S+):\s+(.*)/) {

1247 push(@headers, [ $1, $2 ]);

1248 $mail->{'rawheaders'} .= "$1: $2\n";

1249 }

1250 elsif (/^\s+(.*)/) {

1251 $headers[$#headers]->[1] .= $1 unless($#headers < 0);

1252 $mail->{'rawheaders'} .= $_."\n";

1253 }

1254 }

1255 close(QF);

1256 $mail->{'headers'} = \@headers;

1257 foreach $h (@headers) {

1258 $mail->{'header'}->{lc($h->[0])} = $h->[1];

1259 }

1260

1261 if ($mail->{'dfile'}) {

1262 # Read the mail body

1263 open(DF, $mail->{'dfile'});

1264 while(<DF>) {

1265 $mail->{'body'} .= $_;

1266 }

1267 close(DF);

1268 }

1269 local $datafile = $mail->{'dfile'};

1270 if (!$datafile) {

1271 ($datafile = $mail->{'file'}) =~ s/\/(qf|hf|Qf)/\/df/;

1272 }

1273 local @st0 = stat($mail->{'file'});

1274 local @st1 = stat($datafile);

1275 $mail->{'size'} = $st0[7] + $st1[7];

1276 return $mail;

1277 }

1278

1279 # wrap_lines(text, width)

1280 # Given a multi-line string, return an array of lines wrapped to

1281 # the given width

1282 sub wrap_lines

1283 {

1284 local @rv;

1285 local $w = $_[1];

1286 foreach $rest (split(/\n/, $_[0])) {

1287 if ($rest =~ /\S/) {

1288 while($rest =~ /^(.{1,$w}\S*)\s*([\0-\377]*)$/) {

1289 push(@rv, $1);

1290 $rest = $2;

1291 }

1292 }

1293 else {

1294 # Empty line .. keep as it is

1295 push(@rv, $rest);

1296 }

1297 }

1298 return @rv;

1299 }

1300

1301 # smtp_command(handle, command, no-error)

1302 sub smtp_command

1303 {

1304 local ($m, $c) = @_;

1305 print $m $c;

1306 local $r = <$m>;

1307 if ($r !~ /^[23]\d+/ && !$_[2]) {

1308 &error(&text('send_esmtp', "<tt>".&html_escape($c)."</tt>",

1309 "<tt>".&html_escape($r)."</tt>"));

1310 }

1311 $r =~ s/\r|\n//g;

1312 if ($r =~ /^(\d+)\-/) {

1313 # multi-line ESMTP response!

1314 while(1) {

1315 local $nr = <$m>;

1316 $nr =~ s/\r|\n//g;

1317 if ($nr =~ /^(\d+)\-(.*)/) {

1318 $r .= "\n".$2;

1319 }

1320 elsif ($nr =~ /^(\d+)\s+(.*)/) {

1321 $r .= "\n".$2;

1322 last;

1323 }

1324 }

1325 }

1326 return $r;

1327 }

1328

1329 # address_parts(string)

1330 # Returns the email addresses in a string

1331 sub address_parts

1332 {

1333 local @rv = map { $_->[0] } &split_addresses($_[0]);

1334 return wantarray ? @rv : $rv[0];

1335 }

1336

1337 # link_urls(text, separate)

1338 # Converts URLs into HTML links

1339 sub link_urls

1340 {

1341 local $r = $_[0];

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;

1344 return $r;

1345 }

1346

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

1350 {

1351 local $l = $_[0];

1352 local $rv;

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>";

1358 $l = $after;

1359 }

1360 $rv .= &eucconv_and_escape($l);

1361 return $rv;

1362 }

1363

1364 # links_urls_new_target(html)

1365 # Converts any links without targets to open in a new window

1366 sub links_urls_new_target

1367 {

1368 local $l = $_[0];

1369 local $rv;

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);

1374 }

1375 $rv .= $before."<a ".$a.">";

1376 }

1377 $rv .= $l;

1378 return $rv;

1379 }

1380

1381 # uudecode(text)

1382 sub uudecode

1383 {

1384 local @lines = split(/\n/, $_[0]);

1385 local ($l, $data);

1386 for($l=0; $lines[$l] !~ /begin\s+([0-7]+)\s/i; $l++) { }

1387 while($lines[++$l]) {

1388 $data .= unpack("u", $lines[$l]);

1389 }

1390 return $data;

1391 }

1392

1393 # simplify_date(datestring, [format])

1394 # Given a date from an email header, convert to the user's preferred format

1395 sub simplify_date

1396 {

1397 local ($date, $fmt) = @_;

1398 local $u = &parse_mail_date($date);

1399 if ($u) {

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" :

1403 "%Y/%m/%d";

1404 return strftime("$strf %H:%M", localtime($u));

1405 }

1406 elsif ($date =~ /^(\S+),\s+0*(\d+)\s+(\S+)\s+(\d+)\s+(\d+):(\d+)/) {

1407 return "$2/$3/$4 $5:$6";

1408 }

1409 elsif ($date =~ /^0*(\d+)\s+(\S+)\s+(\d+)\s+(\d+):(\d+)/) {

1410 return "$1/$2/$3 $4:$5";

1411 }

1412 return $date;

1413 }

1414

1415 # simplify_from(from)

1416 # Simplifies a From: address for display in the mail list. Only the first

1417 # address is returned.

1418 sub simplify_from

1419 {

1420 local $rv = &eucconv(&decode_mimewords($_[0]));

1421 local @sp = &split_addresses($rv);

1422 if (!@sp) {

1423 return $text{'mail_nonefrom'};

1424 }

1425 else {

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)." ..";

1429 }

1430 else {

1431 return $first.(@sp > 1 ? " , ..." : "");

1432 }

1433 }

1434 }

1435

1436 # simplify_subject(subject)

1437 # Simplifies and truncates a subject for display in the mail list

1438 sub simplify_subject

1439 {

1440 local $rv = &eucconv(&decode_mimewords($_[0]));

1441 $rv = substr($rv, 0, 80)." .." if (length($rv) > 80);

1442 return &html_escape($rv);

1443 }

1444

1445 # quoted_decode(text)

1446 # Converts quoted-printable format to the original

1447 sub quoted_decode

1448 {

1449 local $t = $_[0];

1450 $t =~ s/[ \t]+?(\r?\n)/$1/g;

1451 $t =~ s/=\r?\n//g;

1452 $t =~ s/(^|[^\r])\n\Z/$1\r\n/;

1453 $t =~ s/=([a-fA-F0-9]{2})/pack("c",hex($1))/ge;

1454 return $t;

1455 }

1456

1457 # quoted_encode(text)

1458 # Encodes text to quoted-printable format

1459 sub quoted_encode

1460 {

1461 local $t = $_[0];

1462 $t =~ s/([=\177-\377])/sprintf("=%2.2X",ord($1))/ge;

1463 return $t;

1464 }

1465

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 {

1470 my $encstr = shift;

1471 my %params = @_;

1472 my @tokens;

1473 $@ = ''; ### error-return

1474

1475 ### Collapse boundaries between adjacent encoded words:

1476 $encstr =~ s{(\?\=)\r?\n[ \t](\=\?)}{$1$2}gs;

1477 pos($encstr) = 0;

1478 ### print STDOUT "ENC = [", $encstr, "]\n";

1479

1480 ### Decode:

1481 my ($charset, $encoding, $enc, $dec);

1482 while (1) {

1483 last if (pos($encstr) >= length($encstr));

1484 my $pos = pos($encstr); ### save it

1485

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 +

1491 \?= # "?="

1492 }xgi) {

1493 ($charset, $encoding, $enc) = ($1, lc($2), $3);

1494 $dec = (($encoding eq 'q') ? _decode_Q($enc) : _decode_B($enc));

1495 push @tokens, [$dec, $charset];

1496 next;

1497 }

1498

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, ['=?'];

1505 next;

1506 }

1507

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

1514 }xg) {

1515 length($1) or die "MIME::Words: internal logic err: empty token\n";

1516 push @tokens, [$1];

1517 next;

1518 }

1519

1520 ### Case 4: bug!

1521 die "MIME::Words: unexpected case:\n($encstr) pos $pos\n\t".

1522 "Please alert developer.\n";

1523 }

1524 return join('',map {$_->[0]} @tokens);

1525 }

1526

1527 # _decode_Q STRING

1528 # Private: used by _decode_header() to decode "Q" encoding, which is

1529 # almost, but not exactly, quoted-printable. :-P

1530 sub _decode_Q {

1531 my $str = shift;

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

1534 $str;

1535 }

1536

1537 # _decode_B STRING

1538 # Private: used by _decode_header() to decode "B" encoding.

1539 sub _decode_B {

1540 my $str = shift;

1541 &decode_base64($str);

1542 }

1543

1544 # encode_mimewords(string, %params)

1545 # Converts a word with 8-bit characters to MIME words format

1546 sub encode_mimewords

1547 {

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";

1553

1554 if ($rawstr =~ /^[\x20-\x7E]*$/) {

1555 # No encoding needed

1556 return $rawstr;

1557 }

1558

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

1562 my $word;

1563 $rawstr =~ s{([ a-zA-Z0-9\x7F-\xFF]{1,18})}{ ### get next "word"

1564 $word = $1;

1565 $word =~ /(?:[$NONPRINT])|(?:^\s+$)/o ?

1566 encode_mimeword($word, $encoding, $charset) : # unsafe chars

1567 $word # OK word

1568 }xeg;

1569 $rawstr =~ s/\?==\?/?= =?/g;

1570 return $rawstr;

1571 }

1572

1573 # encode_mimewords_address(string, %params)

1574 # Given a string containing addresses into one with real names mime-words

1575 # escaped

1576 sub encode_mimewords_address

1577 {

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

1584 return $rawstr;

1585 }

1586 my @rv;

1587 foreach my $addr (&split_addresses($rawstr)) {

1588 my ($email, $name, $orig) = @$addr;

1589 if ($name =~ /^[\x20-\x7E]*$/) {

1590 # No encoding needed

1591 push(@rv, $orig);

1592 }

1593 else {

1594 # Re-encode name

1595 my $ename = encode_mimeword($name, $encoding, $charset);

1596 push(@rv, $ename." <".$email.">");

1597 }

1598 }

1599 return join(", ", @rv);

1600 }

1601

1602 # encode_mimeword(string, [encoding], [charset])

1603 # Converts a word with 8-bit characters to MIME words format

1604 sub encode_mimeword

1605 {

1606 my $word = shift;

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) . "?=";

1611 }

1612

1613 # _encode_Q STRING

1614 # Private: used by _encode_header() to decode "Q" encoding, which is

1615 # almost, but not exactly, quoted-printable. :-P

1616 sub _encode_Q {

1617 my $str = shift;

1618 my $NONPRINT = "\\x00-\\x1F\\x7F-\\xFF";

1619 $str =~ s{([ _\?\=$NONPRINT])}{sprintf("=%02X", ord($1))}eog;

1620 return $str;

1621 }

1622

1623 # _encode_B STRING

1624 # Private: used by _decode_header() to decode "B" encoding.

1625 sub _encode_B {

1626 my $str = shift;

1627 my $enc = &encode_base64($str);

1628 $enc =~ s/\n//;

1629 return $enc;

1630 }

1631

1632 # user_mail_file(user|file, [other details])

1633 sub user_mail_file

1634 {

1635 if ($_[0] =~ /^\//) {

1636 return $_[0];

1637 }

1638 elsif ($config{'mail_dir'}) {

1639 return &mail_file_style($_[0], $config{'mail_dir'},

1640 $config{'mail_style'});

1641 }

1642 elsif (@_ > 1) {

1643 return "$_[7]/$config{'mail_file'}";

1644 }

1645 else {

1646 local @u = getpwnam($_[0]);

1647 return "$u[7]/$config{'mail_file'}";

1648 }

1649 }

1650

1651 # mail_file_style(user, basedir, style)

1652 sub mail_file_style

1653 {

1654 if ($_[2] == 0) {

1655 return "$_[1]/$_[0]";

1656 }

1657 elsif ($_[2] == 1) {

1658 return $_[1]."/".substr($_[0], 0, 1)."/".$_[0];

1659 }

1660 elsif ($_[2] == 2) {

1661 return $_[1]."/".substr($_[0], 0, 1)."/".

1662 substr($_[0], 0, 2)."/".$_[0];

1663 }

1664 else {

1665 return $_[1]."/".substr($_[0], 0, 1)."/".

1666 substr($_[0], 1, 1)."/".$_[0];

1667 }

1668 }

1669

1670 # user_index_file(user|file)

1671 sub user_index_file

1672 {

1673 local $us = $_[0];

1674 $us =~ s/\//_/g;

1675 local $f;

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";

1683 }

1684 else {

1685 $f = $user_module_config_directory ?

1686 "$user_module_config_directory/$us.findex" :

1687 "$module_config_directory/$us.findex";

1688 }

1689 }

1690 else {

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";

1695 }

1696 return -r $f && !-r "$f.$hn" ? $f : "$f.$hn";

1697 }

1698

1699 # extract_mail(data)

1700 # Converts the text of a message into mail object.

1701 sub extract_mail

1702 {

1703 local $text = $_[0];

1704 $text =~ s/^\s+//;

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";

1711 }

1712 elsif ($alines[$i] =~ /^\s+(.*)/) {

1713 $aheaders[$#aheaders]->[1] .= $1 unless($#aheaders < 0);

1714 $amail->{'rawheaders'} .= $alines[$i]."\n";

1715 }

1716 $i++;

1717 }

1718 $amail->{'headers'} = \@aheaders;

1719 foreach $h (@aheaders) {

1720 $amail->{'header'}->{lc($h->[0])} = $h->[1];

1721 }

1722 splice(@alines, 0, $i);

1723 $amail->{'body'} = join("\n", @alines)."\n";

1724 return $amail;

1725 }

1726

1727 # split_addresses(string)

1728 # Splits a comma-separated list of addresses into [ email, real-name, original ]

1729 # triplets

1730 sub split_addresses

1731 {

1732 local (@rv, $str = $_[0]);

1733 while(1) {

1734 $str =~ s/\\"/\0/g;

1735 if ($str =~ /^[\s,]*(([^<>\s]+)\s+$([^\($]+)\))(.*)$/) {

1736 # An address like foo@bar.com (Fooey Bar)

1737 push(@rv, [ $2, $3, $1 ]);

1738 $str = $4;

1739 }

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]

1750 # <foo@bar.com>

1751 # <group name>

1752 # foo@bar.com or foo

1753 my ($all, $name, $email, $rest) = ($1, $2, $3, $4);

1754 $all =~ s/\0/\\"/g;

1755 $name =~ s/\0/"/g;

1756 push(@rv, [ $email, $name eq "," ? "" : $name, $all ]);

1757 $str = $rest;

1758 }

1759 else {

1760 last;

1761 }

1762 }

1763 return @rv;

1764 }

1765

1766 $match_ascii = '\x1b\([BHJ]([\t\x20-\x7e]*)';

1767 $match_jis = '\x1b\$[@B](([\x21-\x7e]{2})*)';

1768

1769 sub eucconv {

1770 local($_) = @_;

1771 if ($current_lang eq 'ja_JP.euc') {

1772 s/$match_jis/&j2e($1)/geo;

1773 s/$match_ascii/$1/go;

1774 }

1775 $_;

1776 }

1777

1778 sub j2e {

1779 local($_) = @_;

1780 tr/\x21-\x7e/\xa1-\xfe/;

1781 $_;

1782 }

1783

1784 # eucconv_and_escape(string)

1785 sub eucconv_and_escape {

1786 return &html_escape(&eucconv($_[0]));

1787 }

1788

1789 # list_maildir(file, [start], [end], [headersonly])

1790 # Returns a subset of mail from a maildir format directory

1791 sub list_maildir

1792 {

1793 local (@rv, $i, $f);

1794 &mark_read_maildir($_[0]);

1795 local @files = &get_maildir_files($_[0]);

1796

1797 local ($start, $end);

1798 if (!defined($_[1])) {

1799 $start = 0;

1800 $end = @files - 1;

1801 }

1802 elsif ($_[2] < 0) {

1803 $start = @files + $_[2] - 1;

1804 $end = @files + $_[1] - 1;

1805 $start = 0 if ($start < 0);

1806 }

1807 else {

1808 $start = $_[1];

1809 $end = $_[2];

1810 $end = @files-1 if ($end >= @files);

1811 }

1812 foreach $f (@files) {

1813 if ($i < $start || $i > $end) {

1814 # Skip files outside requested index range

1815 push(@rv, undef);

1816 $i++;

1817 next;

1818 }

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);

1823 push(@rv, $mail);

1824 }

1825 return @rv;

1826 }

1827

1828 # idlist_maildir(file)

1829 # Returns a list of files in a maildir, which form the IDs

1830 sub idlist_maildir

1831 {

1832 local ($file) = @_;

1833 &mark_read_maildir($file);

1834 return map { substr($_, length($file)+1) } &get_maildir_files($file);

1835 }

1836

1837 # select_maildir(file, &ids, headersonly)

1838 # Returns a list of messages with the given IDs, from a maildir directory

1839 sub select_maildir

1840 {

1841 local ($file, $ids, $headersonly) = @_;

1842 &mark_read_maildir($file);

1843 local @files = &get_maildir_files($file);

1844 local @rv;

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 }

1853 @files;

1854 if ($newfile) {

1855 $path = $newfile;

1856 $mail = &read_mail_file($path, $headersonly);

1857 }

1858 }

1859 if (!$mail && $path =~ /\/cur\//) {

1860 # May have moved - update path

1861 $path =~ s/\/cur\//\/new\//g;

1862 $mail = &read_mail_file($path, $headersonly);

1863 }

1864 if ($mail) {

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);

1870 }

1871 push(@rv, $mail);

1872 }

1873 return @rv;

1874 }

1875

1876 # Get ordered list of message files (with in-memory and on-disk caching, as

1877 # this can be slow)

1878 # get_maildir_files(directory)

1879 sub get_maildir_files

1880 {

1881 # Work out last modified time

1882 local $newest;

1883 foreach my $d ("$_[0]/cur", "$_[0]/new") {

1884 local @dst = stat($d);

1885 $newest = $dst[9] if ($dst[9] > $newest);

1886 }

1887 local $skipt = $config{'maildir_deleted'} || $userconfig{'maildir_deleted'};

1888

1889 local @files;

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]}};

1894 }

1895 else {

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);

1902 while(<CACHE>) {

1903 chop;

1904 push(@files, $_[0]."/".$_);

1905 }

1906 close(CACHE);

1907 $main::list_maildir_cache_time{$_[0]} = $cst[9];

1908 }

1909 else {

1910 # Really read

1911 local @shorts;

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

1918 next;

1919 }

1920 push(@shorts, "$d/$f")

1921 }

1922 closedir(DIR);

1923 }

1924 @shorts = sort { substr($a, 4) cmp substr($b, 4) } @shorts;

1925 @files = map { "$_[0]/$_" } @shorts;

1926

1927 # Write out the on-disk cache

1928 if ($cachefile) {

1929 &open_tempfile(CACHE, ">$cachefile", 1);

1930 my $err;

1931 foreach my $f (@shorts) {

1932 my $ok = (print CACHE $f,"\n");

1933 $err++ if (!$ok);

1934 }

1935 &close_tempfile(CACHE) if (!$err);

1936 local @st = stat($_[0]);

1937 if ($< == 0) {

1938 # Cache should have some ownership as directory

1939 &set_ownership_permissions($st[4], $st[5],

1940 undef, $cachefile);

1941 }

1942 }

1943 $main::list_maildir_cache_time{$_[0]} = $st[9];

1944 }

1945 $main::list_maildir_cache{$_[0]} = \@files;

1946 }

1947 return @files;

1948 }

1949

1950 # search_maildir(file, field, what)

1951 # Search for messages in a maildir directory, and return the results

1952 sub search_maildir

1953 {

1954 return &advanced_search_maildir($_[0], [ [ $_[1], $_[2] ] ], 1);

1955 }

1956

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

1960 {

1961 &mark_read_maildir($_[0]);

1962 local @rv;

1963 local ($min, $max);

1964 if ($_[3] && $_[3]->{'latest'}) {

1965 $min = -1;

1966 $max = -$_[3]->{'latest'};

1967 }

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));

1972 }

1973 return @rv;

1974 }

1975

1976 # mark_read_maildir(dir)

1977 # Move any messages in the 'new' directory of this maildir to 'cur'

1978 sub mark_read_maildir

1979 {

1980 local ($dir) = @_;

1981 local @files = &get_maildir_files($dir);

1982 local $i = 0;

1983 foreach my $nf (@files) {

1984 if (substr($nf, length($dir)+1, 3) eq "new") {

1985 local $cf = $nf;

1986 $cf =~ s/\/new\//\/cur\//g;

1987 if (rename($nf, $cf)) {

1988 $files[$i] = $cf;

1989 $changed = 1;

1990 }

1991 }

1992 $i++;

1993 }

1994 if ($changed) {

1995 # Update the cache

1996 $main::list_maildir_cache{$dir} = \@files;

1997 local $cachefile = &get_maildir_cachefile($dir);

1998 if ($cachefile) {

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");

2003 }

2004 &close_tempfile(CACHE);

2005 local @st = stat($_[0]);

2006 if ($< == 0) {

2007 &set_ownership_permissions($st[4], $st[5],

2008 undef, $cachefile);

2009 }

2010 }

2011 }

2012 }

2013

2014 # delete_maildir(&mail, ...)

2015 # Delete messages from a maildir directory

2016 sub delete_maildir

2017 {

2018 local $m;

2019

2020 # Find all maildirs being deleted from

2021 local %dirs;

2022 foreach $m (@_) {

2023 if ($m->{'file'} =~ /^(.*)\/(cur|new)\/([^\/]+)$/) {

2024 $dirs{$1}->{"$2/$3"} = 1;

2025 }

2026 }

2027

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);

2033 next if (!@cst);

2034

2035 # Work out last modified time, and don't update cache if too new

2036 local $newest;

2037 foreach my $d ("$dir/cur", "$dir/new") {

2038 local @dst = stat($d);

2039 $newest = $dst[9] if ($dst[9] > $newest);

2040 }

2041 next if ($newest > $cst[9]);

2042

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);

2048 }

2049 }

2050 &flush_file_lines($cachefile);

2051 }

2052

2053 # Actually delete the files

2054 foreach $m (@_) {

2055 unlink($m->{'file'});

2056 }

2057

2058 }

2059

2060 # modify_maildir(&oldmail, &newmail, textonly)

2061 # Replaces a message in a maildir directory

2062 sub modify_maildir

2063 {

2064 unlink($_[0]->{'file'});

2065 &send_mail($_[1], $_[0]->{'file'}, $_[2], 1);

2066 }

2067

2068 # write_maildir(&mail, directory, textonly)

2069 # Adds some message in maildir format to a directory

2070 sub write_maildir

2071 {

2072 # Work out last modified time, and don't update cache if too new

2073 local $cachefile = &get_maildir_cachefile($_[1]);

2074 local $up2date = 0;

2075 if ($cachefile) {

2076 local @cst = stat($cachefile);

2077 if (@cst) {

2078 local $newest;

2079 foreach my $d ("$dir/cur", "$dir/new") {

2080 local @dst = stat($d);

2081 $newest = $dst[9] if ($dst[9] > $newest);

2082 }

2083 $up2date = 1 if ($newest <= $cst[9]);

2084 }

2085 }

2086

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;

2093

2094 # Set ownership of the new message file to match the directory

2095 local @st = stat($_[1]);

2096 if ($< == 0) {

2097 &set_ownership_permissions($st[4], $st[5], undef, $mf);

2098 }

2099

2100 # Create tmp and new sub-dirs, if missing

2101 foreach my $sd ("tmp", "new") {

2102 local $sdpath = "$_[1]/$sd";

2103 if (!-d $sdpath) {

2104 mkdir($sdpath, 0755);

2105 if ($< == 0) {

2106 &set_ownership_permissions($st[4], $st[5],

2107 undef, $sdpath);

2108 }

2109 }

2110 }

2111

2112 if ($up2date && $cachefile) {

2113 # Bring cache up to date

2114 $now--;

2115 local $lref = &read_file_lines($cachefile);

2116 push(@$lref, $_[0]->{'id'});

2117 &flush_file_lines($cachefile);

2118 }

2119 }

2120

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

2124 {

2125 local ($dir) = @_;

2126 mkdir("$dir/cur", 0755);

2127 local $now = time();

2128 local $hn = &get_system_hostname();

2129 ++$main::write_maildir_count;

2130 local $rv;

2131 do {

2132 $rv = "cur/$now.$$.$main::write_maildir_count.$hn";

2133 $now++;

2134 } while(-r "$dir/$rv");

2135 return $rv;

2136 }

2137

2138 # empty_maildir(file)

2139 # Delete all messages in an maildir directory

2140 sub empty_maildir

2141 {

2142 local $d;

2143 foreach $d ("$_[0]/cur", "$_[0]/new") {

2144 local $f;

2145 opendir(DIR, $d);

2146 while($f = readdir(DIR)) {

2147 unlink("$d/$f") if ($f ne '.' && $f ne '..');

2148 }

2149 closedir(DIR);

2150 }

2151 &flush_maildir_cachefile($_[0]);

2152 }

2153

2154 # get_maildir_cachefile(dir)

2155 # Returns the cache file for a maildir directory

2156 sub get_maildir_cachefile

2157 {

2158 local ($dir) = @_;

2159 local $cd = $user_module_config_directory || $module_config_directory;

2160 local $sd = "$cd/maildircache";

2161 if (!-d $sd) {

2162 &make_dir($sd, 0755) || return undef;

2163 }

2164 $dir =~ s/\//_/g;

2165 return "$sd/$dir";

2166 }

2167

2168 # flush_maildir_cachefile(dir)

2169 # Clear the on-disk and in-memory maildir caches

2170 sub flush_maildir_cachefile

2171 {

2172 local ($dir) = @_;

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});

2177 }

2178

2179 # count_maildir(dir)

2180 # Returns the number of messages in a maildir directory

2181 sub count_maildir

2182 {

2183 local @files = &get_maildir_files($_[0]);

2184 return scalar(@files);

2185 }

2186

2187 # list_mhdir(file, [start], [end], [headersonly])

2188 # Returns a subset of mail from an MH format directory

2189 sub list_mhdir

2190 {

2191 local ($start, $end, $f, $i, @rv);

2192 opendir(DIR, $_[0]);

2193 local @files = map { "$_[0]/$_" }

2194 sort { $a <=> $b }

2195 grep { /^\d+$/ } readdir(DIR);

2196 closedir(DIR);

2197 if (!defined($_[1])) {

2198 $start = 0;

2199 $end = @files - 1;

2200 }

2201 elsif ($_[2] < 0) {

2202 $start = @files + $_[2] - 1;

2203 $end = @files + $_[1] - 1;

2204 $start = 0 if ($start < 0);

2205 }

2206 else {

2207 $start = $_[1];

2208 $end = $_[2];

2209 $end = @files-1 if ($end >= @files);

2210 }

2211 foreach $f (@files) {

2212 if ($i < $start || $i > $end) {

2213 # Skip files outside requested index range

2214 push(@rv, undef);

2215 $i++;

2216 next;

2217 }

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);

2222 push(@rv, $mail);

2223 }

2224 return @rv;

2225 }

2226

2227 # idlist_mhdir(directory)

2228 # Returns a list of files in an MH directory, which are the IDs

2229 sub idlist_mhdir

2230 {

2231 local ($dir) = @_;

2232 opendir(DIR, $dir);

2233 local @files = grep { /^\d+$/ } readdir(DIR);

2234 closedir(DIR);

2235 return @files;

2236 }

2237

2238 # get_mhdir_files(directory)

2239 # Returns a list of full paths to files in an MH directory

2240 sub get_mhdir_files

2241 {

2242 local ($dir) = @_;

2243 return map { "$dir/$_" } &idlist_mhdir($dir);

2244 }

2245

2246 # select_mhdir(file, &ids, headersonly)

2247 # Returns a list of messages with the given indexes, from an mhdir directory

2248 sub select_mhdir

2249 {

2250 local ($file, $ids, $headersonly) = @_;

2251 local @rv;

2252 opendir(DIR, $file);

2253 local @files = map { "$file/$_" }

2254 sort { $a <=> $b }

2255 grep { /^\d+$/ } readdir(DIR);

2256 closedir(DIR);

2257 foreach my $i (@$ids) {

2258 local $mail = &read_mail_file("$file/$i", $headersonly);

2259 if ($mail) {

2260 $mail->{'idx'} = &indexof("$file/$i", @files);

2261 $mail->{'id'} = $i;

2262 }

2263 push(@rv, $mail);

2264 }

2265 return @rv;

2266 }

2267

2268 # search_mhdir(file|user, field, what)

2269 # Search for messages in an MH directory, and return the results

2270 sub search_mhdir

2271 {

2272 return &advanced_search_mhdir($_[0], [ [ $_[1], $_[2] ] ], 1);

2273 }

2274

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

2278 {

2279 local @rv;

2280 local ($min, $max);

2281 if ($_[3] && $_[3]->{'latest'}) {

2282 $min = -1;

2283 $max = -$_[3]->{'latest'};

2284 }

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));

2288 }

2289 return @rv;

2290 }

2291

2292 # delete_mhdir(&mail, ...)

2293 # Delete messages from an MH directory

2294 sub delete_mhdir

2295 {

2296 local $m;

2297 foreach $m (@_) {

2298 unlink($m->{'file'});

2299 }

2300 }

2301

2302 # modify_mhdir(&oldmail, &newmail, textonly)

2303 # Replaces a message in a maildir directory

2304 sub modify_mhdir

2305 {

2306 unlink($_[0]->{'file'});

2307 &send_mail($_[1], $_[0]->{'file'}, $_[2], 1);

2308 }

2309

2310 # max_mhdir(dir)

2311 # Returns the maximum message ID in the directory

2312 sub max_mhdir

2313 {

2314 local $max = 1;

2315 opendir(DIR, $_[0]);

2316 foreach $f (readdir(DIR)) {

2317 $max = $f if ($f =~ /^\d+$/ && $f > $max);

2318 }

2319 closedir(DIR);

2320 return $max;

2321 }

2322

2323 # empty_mhdir(file)

2324 # Delete all messages in an MH format directory

2325 sub empty_mhdir

2326 {

2327 local $f;

2328 opendir(DIR, $_[0]);

2329 foreach $f (readdir(DIR)) {

2330 unlink("$_[0]/$f") if ($f =~ /^\d+$/);

2331 }

2332 closedir(DIR);

2333 }

2334

2335 # count_mhdir(file)

2336 # Returns the number of messages in an MH directory

2337 sub count_mhdir

2338 {

2339 opendir(DIR, $_[0]);

2340 local @files = grep { /^\d+$/ } readdir(DIR);

2341 closedir(DIR);

2342 return scalar(@files);

2343 }

2344

2345 # read_mail_file(file, [headersonly])

2346 # Read a single message from a file

2347 sub read_mail_file

2348 {

2349 local (@headers, $mail);

2350

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];

2355 close(MAIL);

2356 local @st = stat($_[0]);

2357 $mail->{'size'} = $st[7];

2358 $mail->{'time'} = $st[9];

2359

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;

2367 }

2368

2369 return $mail;

2370 }

2371

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 -

2376 sub read_mail_fh

2377 {

2378 local ($fh, $endmode, $headeronly) = @_;

2379 local (@headers, $mail);

2380

2381 # Read the headers

2382 local $lnum = 0;

2383 while(1) {

2384 $lnum++;

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";

2392 }

2393 elsif ($line =~ /^\s+(.*)/) {

2394 $headers[$#headers]->[1] .= " ".$1 unless($#headers < 0);

2395 $mail->{'rawheaders'} .= $line."\n";

2396 }

2397 elsif ($line =~ /^From\s+(\S+).*\d+/ &&

2398 ($1 ne '-' || $endmode == 2)) {

2399 $mail->{'fromline'} = $line;

2400 }

2401 }

2402 $mail->{'headers'} = \@headers;

2403 foreach $h (@headers) {

2404 $mail->{'header'}->{lc($h->[0])} = $h->[1];

2405 }

2406

2407 if (!$headersonly) {

2408 # Read the mail body

2409 if ($endmode == 0) {

2410 # Till EOF

2411 while(read($fh, $buf, 1024) > 0) {

2412 $mail->{'size'} += length($buf);

2413 $mail->{'body'} .= $buf;

2414 $lc = ($buf =~ tr/\n/\n/);

2415 $lnum += $lc;

2416 }

2417 close(MAIL);

2418 }

2419 else {

2420 # Tell next From line

2421 while(1) {

2422 $line = <$fh>;

2423 last if (!$line || $line =~ /^From\s+(\S+).*\d+\r?\n/ &&

2424 ($1 ne '-' || $endmode == 2));

2425 $lnum++;

2426 $mail->{'size'} += length($line);

2427 $mail->{'body'} .= $line;

2428 }

2429 }

2430 $mail->{'lines'} = $lnum;

2431 }

2432 elsif ($endmode) {

2433 # Not reading the body, but we still need to search till the next

2434 # From: line in order to get the size

2435 while(1) {

2436 $line = <$fh>;

2437 last if (!$line || $line =~ /^From\s+(\S+).*\d+\r?\n/ &&

2438 ($1 ne '-' || $endmode == 2));

2439 $lnum++;

2440 $mail->{'size'} += length($line);

2441 }

2442 $mail->{'lines'} = $lnum;

2443 }

2444 return $mail;

2445 }

2446

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

2450 sub dash_mode

2451 {

2452 open(DASH, &user_mail_file($_[0])) || return 0; # assume no

2453 local $line = <DASH>;

2454 close(DASH);

2455 return $line =~ /^From\s+(\S+).*\d/ && $1 eq '-';

2456 }

2457

2458 # mail_matches(&fields, andmode, &mail)

2459 # Returns 1 if some message matches a search

2460 sub mail_matches

2461 {

2462 local $count = 0;

2463 local $f;

2464 foreach $f (@{$_[0]}) {

2465 local $field = $f->[0];

2466 local $what = $f->[1];

2467 local $neg = ($field =~ s/^\!//);

2468 if ($field eq 'body') {

2469 $count++

2470 if (!$neg && $_[2]->{'body'} =~ /\Q$what\E/i ||

2471 $neg && $_[2]->{'body'} !~ /\Q$what\E/i);

2472 }

2473 elsif ($field eq 'size') {

2474 $count++

2475 if (!$neg && $_[2]->{'size'} > $what ||

2476 $neg && $_[2]->{'size'} < $what);

2477 }

2478 elsif ($field eq 'headers') {

2479 local $headers = $_[2]->{'rawheaders'} ||

2480 join("", map { $_->[0].": ".$_->[1]."\n" }

2481 @{$_[2]->{'headers'}});

2482 $count++

2483 if (!$neg && $headers =~ /\Q$what\E/i ||

2484 $neg && $headers !~ /\Q$what\E/i);

2485 }

2486 elsif ($field eq 'all') {

2487 local $headers = $_[2]->{'rawheaders'} ||

2488 join("", map { $_->[0].": ".$_->[1]."\n" }

2489 @{$_[2]->{'headers'}});

2490 $count++

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));

2495 }

2496 elsif ($field eq 'status') {

2497 $count++

2498 if (!$neg && $_[2]->{$field} =~ /\Q$what\E/i||

2499 $neg && $_[2]->{$field} !~ /\Q$what\E/i);

2500 }

2501 else {

2502 $count++

2503 if (!$neg && $_[2]->{'header'}->{$field} =~ /\Q$what\E/i||

2504 $neg && $_[2]->{'header'}->{$field} !~ /\Q$what\E/i);

2505 }

2506 return 1 if ($count && !$_[1]);

2507 }

2508 return $count == scalar(@{$_[0]});

2509 }

2510

2511 # search_fields(&fields)

2512 # Returns an array of headers/fields from a search

2513 sub search_fields

2514 {

2515 local @rv;

2516 foreach my $f (@{$_[0]}) {

2517 $f->[0] =~ /^\!?(.*)$/;

2518 push(@rv, $1);

2519 }

2520 return &unique(@rv);

2521 }

2522

2523 # matches_needs_body(&fields)

2524 # Returns 1 if a search needs to check the mail body

2525 sub matches_needs_body

2526 {

2527 foreach my $f (@{$_[0]}) {

2528 return 1 if ($f->[0] eq 'body' || $f->[0] eq 'all');

2529 }

2530 return 0;

2531 }

2532

2533 # parse_delivery_status(text)

2534 # Returns the fields from a message/delivery-status attachment

2535 sub parse_delivery_status

2536 {

2537 local @lines = split(/[\r\n]+/, $_[0]);

2538 local (%rv, $l);

2539 foreach $l (@lines) {

2540 if ($l =~ /^(\S+):\s*(.*)/) {

2541 $rv{lc($1)} = $2;

2542 }

2543 }

2544 return \%rv;

2545 }

2546

2547 # parse_mail_date(string)

2548 # Converts a mail Date: header into a unix time

2549 sub parse_mail_date

2550 {

2551 local ($str) = @_;

2552 $str =~ s/^[, \t]+//;

2553 $str =~ s/\s+$//;

2554 open(OLDSTDERR, ">&STDERR"); # suppress STDERR from Time::Local

2555 close(STDERR);

2556 my $rv = eval {

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);

2563 local $tz = $8;

2564 if ($tz =~ /^(\-|\+)?\d+$/) {

2565 local $tz = int($tz);

2566 $tz = $tz/100 if ($tz >= 50 || $tz <= -50);

2567 $tm -= $tz*60*60;

2568 }

2569 return $tm;

2570 }

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);

2577 return $tm;

2578 }

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);

2583 return $tm;

2584 }

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),

2590 $now[5]);

2591 return $tm;

2592 }

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),

2598 $now[5]);

2599 return $tm;

2600 }

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),

2606 $now[5]);

2607 return $tm;

2608 }

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);

2613 local $tz = $7;

2614 if ($tz =~ /^(\-|\+)?\d+$/) {

2615 $tz = int($tz);

2616 $tz = $tz/100 if ($tz >= 50 || $tz <= -50);

2617 $tm -= $tz*60*60;

2618 }

2619 return $tm;

2620 }

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);

2625 return $tm;

2626 }

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);

2631 local $tz = $7;

2632 if ($tz =~ /^(\-|\+)?\d+$/) {

2633 $tz = int($tz);

2634 $tz = $tz/100 if ($tz >= 50 || $tz <= -50);

2635 $tm -= $tz*60*60;

2636 }

2637 return $tm;

2638 }

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),

2642 $3-1900);

2643 return $tm;

2644 }

2645 else {

2646 return undef;

2647 }

2648 };

2649 open(STDERR, ">&OLDSTDERR");

2650 close(OLDSTDERR);

2651 if ($@) {

2652 #print STDERR "parsing of $str failed : $@\n";

2653 return undef;

2654 }

2655 return $rv;

2656 }

2657

2658 # send_text_mail(from, to, cc, subject, body, [smtp-server])

2659 # A convenience function for sending a email with just a text body

2660 sub send_text_mail

2661 {

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' => &quoted_encode($body) } :

2668 { 'headers' => [ [ 'Content-type', 'text/plain' ] ],

2669 'data' => &entities_to_ascii($body) };

2670 local $mail = { 'headers' =>

2671 [ [ 'From', $from ],

2672 [ 'To', $to ],

2673 [ 'Cc', $cc ],

2674 [ 'Subject', $subject ] ],

2675 'attach' => [ $attach ] };

2676 return &send_mail($mail, undef, 1, 0, $smtp);

2677 }

2678

2679 # make_from_line(address, [time])

2680 # Returns a From line for mbox emails, based on the current time

2681 sub make_from_line

2682 {

2683 local ($addr, $t) = @_;

2684 $t ||= time();

2685 &clear_time_locale();

2686 local $rv = "From $addr ".strftime("%a %b %e %H:%M:%S %Y", localtime($t));

2687 &reset_time_locale();

2688 return $rv;

2689 }

2690

2691 sub notes_decode

2692 {

2693 # Deprecated - does nothing

2694 }

2695

2696 # add_mailer_ip_headers(&headers)

2697 # Add X-Mailer and X-Originating-IP headers, if enabled

2698 sub add_mailer_ip_headers

2699 {

2700 local ($headers) = @_;

2701 if (!$config{'no_orig_ip'}) {

2702 push(@$headers, [ 'X-Originating-IP', $ENV{'REMOTE_ADDR'} ]);

2703 }

2704 if (!$config{'no_mailer'}) {

2705 push(@$headers, [ 'X-Mailer', ucfirst(&get_product_name())." ".

2706 &get_webmin_version() ]);

2707 }

2708 }

2709

2710 1;