1# boxes-lib.pl 2# Functions to parsing user mail files 3 4use POSIX; 5use Fcntl; 6if ($userconfig{'date_tz'} || $config{'date_tz'}) { 7 # Set the timezone for all date calculations, and force a conversion 8 # now as in some cases the first one fails! 9 $ENV{'TZ'} = $userconfig{'date_tz'} || 10 $config{'date_tz'}; 11 strftime('%H:%M', localtime(time())); 12 } 13use Time::Local; 14 15$dbm_index_min = 1000000; 16$dbm_index_version = 3; 17 18# list_mails(user|file, [start], [end]) 19# Returns a subset of mail from a mbox format file 20sub list_mails 21{ 22local (@rv, $h, $done); 23my %index; 24my $umf = &user_mail_file($_[0]); 25&open_as_mail_user(MAIL, $umf) || &error("Failed to open $umf : $!"); 26&build_dbm_index($_[0], \%index); 27local ($start, $end); 28local $isize = $index{'mailcount'}; 29if (@_ == 1 || !defined($_[1]) && !defined($_[2])) { 30 $start = 0; $end = $isize-1; 31 } 32elsif ($_[2] < 0) { 33 $start = $isize+$_[2]-1; $end = $isize+$_[1]-1; 34 $start = $start<0 ? 0 : $start; 35 } 36else { 37 $start = $_[1]; $end = $_[2]; 38 $end = $isize-1 if ($end >= $isize); 39 } 40$rv[$isize-1] = undef if ($isize); # force array to right size 41local $dash = &dash_mode($_[0]); 42$start = 0 if ($start < 0); 43for($i=$start; $i<=$end; $i++) { 44 # Seek to mail position 45 local @idx = split(/\0/, $index{$i}); 46 local $pos = $idx[0]; 47 local $startline = $idx[1]; 48 seek(MAIL, $pos, 0); 49 50 # Read the mail 51 local $mail = &read_mail_fh(MAIL, $dash ? 2 : 1, 0); 52 $mail->{'line'} = $startline; 53 $mail->{'eline'} = $startline + $mail->{'lines'} - 1; 54 $mail->{'idx'} = $i; 55 # ID is position in file and message ID 56 $mail->{'id'} = $pos." ".$i." ".$startline." ". 57 substr($mail->{'header'}->{'message-id'}, 0, 255); 58 $rv[$i] = $mail; 59 } 60return @rv; 61} 62 63# select_mails(user|file, &ids, headersonly) 64# Returns a list of messages from an mbox with the given IDs. The ID contains 65# the file offset, message number, line and message ID, and the former is used 66# if valid. 67sub select_mails 68{ 69local ($file, $ids, $headersonly) = @_; 70local @rv; 71 72local (@rv); 73my %index; 74local $gotindex; 75 76local $umf = &user_mail_file($file); 77local $dash = &dash_mode($umf); 78&open_as_mail_user(MAIL, $umf) || &error("Failed to open $umf : $!"); 79foreach my $i (@$ids) { 80 local ($pos, $idx, $startline, $wantmid) = split(/ /, $i); 81 82 # Go to where the mail is supposed to be, and check if any starts there 83 seek(MAIL, $pos, 0); 84 local $ll = <MAIL>; 85 local $fromok = $ll !~ /^From\s+(\S+).*\d+\r?\n/ || 86 ($1 eq '-' && !$dash) ? 0 : 1; 87 print DEBUG "seeking to $pos in $umf, got $ll"; 88 if (!$fromok) { 89 # Oh noes! Need to find it 90 if (!$gotindex++) { 91 &build_dbm_index($file, \%index); 92 } 93 $pos = undef; 94 while(my ($k, $v) = each %index) { 95 if (int($k) eq $k) { 96 my ($p, $line, $subject, $from, $mid)= 97 split(/\0/, $v); 98 if ($mid eq $wantmid) { 99 # Found it! 100 $pos = $p; 101 $idx = $k; 102 $startline = $line; 103 last; 104 } 105 } 106 } 107 } 108 109 if (defined($pos)) { 110 # Now we can read 111 seek(MAIL, $pos, 0); 112 local $mail = &read_mail_fh(MAIL, $dash ? 2 : 1, $headersonly); 113 $mail->{'line'} = $startline; 114 $mail->{'eline'} = $startline + $mail->{'lines'} - 1; 115 $mail->{'idx'} = $idx; 116 $mail->{'id'} = "$pos $idx $startline $wantmid"; 117 push(@rv, $mail); 118 } 119 else { 120 push(@rv, undef); # Mail is gone? 121 } 122 } 123close(MAIL); 124return @rv; 125} 126 127# idlist_mails(user|file) 128# Returns a list of IDs in some mbox 129sub idlist_mails 130{ 131my %index; 132local $idlist = &build_dbm_index($_[0], \%index); 133return @$idlist; 134} 135 136# search_mail(user, field, match) 137# Returns an array of messages matching some search 138sub search_mail 139{ 140return &advanced_search_mail($_[0], [ [ $_[1], $_[2] ] ], 1); 141} 142 143# advanced_search_mail(user|file, &fields, andmode, [&limits], [headersonly]) 144# Returns an array of messages matching some search 145sub advanced_search_mail 146{ 147local (%index, @rv, $i); 148local $dash = &dash_mode($_[0]); 149local @possible; # index positions of possible mails 150local $possible_certain = 0; # is possible list authoratative? 151local ($min, $max); 152local $umf = &user_mail_file($_[0]); 153&open_as_mail_user(MAIL, $umf) || &error("Failed to open $umf : $!"); 154 155# We have a DBM index .. if the search includes the from and subject 156# fields, scan it first to cut down on the total time 157&build_dbm_index($_[0], \%index); 158 159# Check which fields are used in search 160local @dbmfields = grep { $_->[0] eq 'from' || 161 $_->[0] eq 'subject' } @{$_[1]}; 162local $alldbm = (scalar(@dbmfields) == scalar(@{$_[1]})); 163 164$min = 0; 165$max = $index{'mailcount'}-1; 166if ($_[3] && $_[3]->{'latest'}) { 167 $min = $max - $_[3]->{'latest'}; 168 } 169 170# Only check DBM if it contains some fields, and if it contains all 171# fields when in 'or' mode. 172if (@dbmfields && ($alldbm || $_[2])) { 173 # Scan the DBM to build up a list of 'possibles' 174 for($i=$min; $i<=$max; $i++) { 175 local @idx = split(/\0/, $index{$i}); 176 local $fake = { 'header' => { 'from', $idx[2], 177 'subject', $idx[3] } }; 178 local $m = &mail_matches(\@dbmfields, $_[2], $fake); 179 push(@possible, $i) if ($m); 180 } 181 $possible_certain = $alldbm; 182 } 183else { 184 # None of the DBM fields are in the search .. have to scan all 185 @possible = ($min .. $max); 186 } 187 188# Need to scan through possible messages to find those that match 189local $headersonly = !&matches_needs_body($_[1]); 190foreach $i (@possible) { 191 # Seek to mail position 192 local @idx = split(/\0/, $index{$i}); 193 local $pos = $idx[0]; 194 local $startline = $idx[1]; 195 seek(MAIL, $pos, 0); 196 197 # Read the mail 198 local $mail = &read_mail_fh(MAIL, $dash ? 2 : 1, $headersonly); 199 $mail->{'line'} = $startline; 200 $mail->{'eline'} = $startline + $mail->{'lines'} - 1; 201 $mail->{'idx'} = $i; 202 $mail->{'id'} = $pos." ".$i." ".$startline." ". 203 substr($mail->{'header'}->{'message-id'}, 0, 255); 204 push(@rv, $mail) if ($possible_certain || 205 &mail_matches($_[1], $_[2], $mail)); 206 } 207return @rv; 208} 209 210# build_dbm_index(user|file, &index) 211# Updates a reference to a DBM hash that indexes the given mail file. 212# Hash contains keys 0, 1, 2 .. each of which has a value containing the 213# position of the mail in the file, line number, subject, sender and message ID. 214# Special key lastchange = time index was last updated 215# mailcount = number of messages in index 216# version = index format version 217# Returns a list of all IDs 218sub build_dbm_index 219{ 220local ($user, $index, $noperm) = @_; 221local $ifile = &user_index_file($user); 222local $umf = &user_mail_file($user); 223local @st = stat($umf); 224if (!defined($noperm)) { 225 # Use global override setting 226 $noperm = $no_permanent_index; 227 } 228if ($noperm && &has_dbm_index($user)) { 229 # Index already exists, so use it 230 $noperm = 0; 231 } 232if (!$noperm) { 233 dbmopen(%$index, $ifile, 0600); 234 } 235 236# Read file of IDs 237local $idsfile = $ifile.".ids"; 238local @ids; 239local $idschanged; 240if (!$noperm && open(IDSFILE, "<", $idsfile)) { 241 @ids = <IDSFILE>; 242 chop(@ids); 243 close(IDSFILE); 244 } 245 246if (scalar(@ids) != $index->{'mailcount'}) { 247 # Build for first time 248 print DEBUG "need meta-index rebuild for $user ",scalar(@ids)," != ",$index->{'mailcount'},"\n"; 249 @ids = ( ); 250 while(my ($k, $v) = each %$index) { 251 if ($k eq int($k) && $k < $index->{'mailcount'}) { 252 local ($pos, $line, $subject, $sender, $mid) = 253 split(/\0/, $v); 254 $ids[$k] = $pos." ".$k." ".$line." ".$mid; 255 } 256 elsif ($k >= $index->{'mailcount'}) { 257 # Old crap that is off the end 258 delete($index->{$k}); 259 } 260 } 261 $index->{'mailcount'} = scalar(@ids); # Now known for sure 262 $idschanged = 1; 263 } 264 265if (!@st || 266 $index->{'lastchange'} < $st[9] || 267 $index->{'lastsize'} != $st[7] || 268 $st[7] < $dbm_index_min || 269 $index->{'version'} != $dbm_index_version) { 270 # The mail file is newer than the index, or we are always re-indexing 271 local $fromok = 1; 272 local ($ll, @idx); 273 local $dash = &dash_mode($umf); 274 if ($st[7] < $dbm_index_min || 275 $index->{'version'} != $dbm_index_version) { 276 $fromok = 0; # Always re-index 277 &open_as_mail_user(IMAIL, $umf); 278 } 279 else { 280 if (&open_as_mail_user(IMAIL, $umf)) { 281 # Check the last 100 messages (at most), to see if 282 # the mail file has been truncated, had mails deleted, 283 # or re-written. 284 local $il = $index->{'mailcount'}-1; 285 local $i; 286 for($i=($il>100 ? 100 : $il); $i>=0; $i--) { 287 @idx = split(/\0/, $index->{$il-$i}); 288 seek(IMAIL, $idx[0], 0); 289 $ll = <IMAIL>; 290 $fromok = 0 if ($ll !~ /^From\s+(\S+).*\d+\r?\n/ || 291 ($1 eq '-' && !$dash)); 292 } 293 } 294 else { 295 $fromok = 0; # No mail file yet 296 } 297 } 298 local ($pos, $lnum, $istart); 299 if ($index->{'mailcount'} && $fromok && $st[7] > $idx[0]) { 300 # Mail file seems to have gotten bigger, most likely 301 # because new mail has arrived ... only reindex the new mails 302 print DEBUG "re-indexing from $idx[0]\n"; 303 $pos = $idx[0] + length($ll); 304 $lnum = $idx[1] + 1; 305 $istart = $index->{'mailcount'}; 306 } 307 else { 308 # Mail file has changed in some other way ... do a rebuild 309 # of the whole index 310 print DEBUG "totally re-indexing\n"; 311 $istart = 0; 312 $pos = 0; 313 $lnum = 0; 314 seek(IMAIL, 0, 0); 315 @ids = ( ); 316 $idschanged = 1; 317 %$index = ( ); 318 } 319 local ($doingheaders, @nidx); 320 while(<IMAIL>) { 321 if (/^From\s+(\S+).*\d+\r?\n/ && ($1 ne '-' || $dash)) { 322 @nidx = ( $pos, $lnum ); 323 $idschanged = 1; 324 push(@ids, $pos." ".$istart." ".$lnum); 325 $index->{$istart++} = join("\0", @nidx); 326 $doingheaders = 1; 327 } 328 elsif ($_ eq "\n" || $_ eq "\r\n") { 329 $doingheaders = 0; 330 } 331 elsif ($doingheaders && /^From:\s*(.{0,255})/i) { 332 $nidx[2] = $1; 333 $index->{$istart-1} = join("\0", @nidx); 334 } 335 elsif ($doingheaders && /^Subject:\s*(.{0,255})/i) { 336 $nidx[3] = $1; 337 $index->{$istart-1} = join("\0", @nidx); 338 } 339 elsif ($doingheaders && /^Message-ID:\s*(.{0,255})/i) { 340 $nidx[4] = $1; 341 $index->{$istart-1} = join("\0", @nidx); 342 $ids[$#ids] .= " ".$1; 343 } 344 $pos += length($_); 345 $lnum++; 346 } 347 close(IMAIL); 348 $index->{'lastchange'} = time(); 349 $index->{'lastsize'} = $st[7]; 350 $index->{'mailcount'} = $istart; 351 $index->{'version'} = $dbm_index_version; 352 } 353 354# Write out IDs file, if needed 355if ($idschanged && !$noperm) { 356 open(IDSFILE, ">", $idsfile); 357 foreach my $id (@ids) { 358 print IDSFILE $id,"\n"; 359 } 360 close(IDSFILE); 361 } 362 363return \@ids; 364} 365 366# has_dbm_index(user|file) 367# Returns 1 if a DBM index exists for some user or file 368sub has_dbm_index 369{ 370local $ifile = &user_index_file($_[0]); 371foreach my $ext (".dir", ".pag", ".db") { 372 return 1 if (-r $ifile.$ext); 373 } 374return 0; 375} 376 377# delete_dbm_index(user|file) 378# Deletes all DBM indexes for a user or file 379sub delete_dbm_index 380{ 381local $ifile = &user_index_file($_[0]); 382foreach my $ext (".dir", ".pag", ".db") { 383 &unlink_file($ifile.$ext); 384 } 385} 386 387# empty_mail(user|file) 388# Truncate a mail file to nothing 389sub empty_mail 390{ 391local ($user) = @_; 392local $umf = &user_mail_file($user); 393local $ifile = &user_index_file($user); 394&open_as_mail_user(TRUNC, ">$umf") || &error("Failed to open $umf : $!"); 395close(TRUNC); 396 397# Set index size to 0 (if there is one) 398if (&has_dbm_index($user)) { 399 local %index; 400 dbmopen(%index, $ifile, 0600); 401 $index{'mailcount'} = 0; 402 $index{'lastchange'} = time(); 403 dbmclose(%index); 404 } 405} 406 407# count_mail(user|file) 408# Returns the number of messages in some mail file 409sub count_mail 410{ 411my %index; 412&build_dbm_index($_[0], \%index); 413return $index{'mailcount'}; 414} 415 416# parse_mail(&mail, [&parent], [savebody], [keep-cr]) 417# Extracts the attachments from the mail body 418sub parse_mail 419{ 420return if ($_[0]->{'parsed'}++); 421local $ct = $_[0]->{'header'}->{'content-type'}; 422local (@attach, $h, $a); 423if ($ct =~ /multipart\/(\S+)/i && ($ct =~ /boundary="([^"]+)"/i || 424 $ct =~ /boundary=([^;\s]+)/i)) { 425 # Multipart MIME message 426 local $bound = "--".$1; 427 local @lines = $_[3] ? split(/\n/, $_[0]->{'body'}) 428 : split(/\r?\n/, $_[0]->{'body'}); 429 local $l; 430 local $max = @lines; 431 while($l < $max && $lines[$l++] ne $bound) { 432 # skip to first boundary 433 } 434 while(1) { 435 # read attachment headers 436 local (@headers, $attach); 437 while($lines[$l]) { 438 $attach->{'raw'} .= $lines[$l]."\n"; 439 $attach->{'rawheaders'} .= $lines[$l]."\n"; 440 if ($lines[$l] =~ /^(\S+):\s*(.*)/) { 441 push(@headers, [ $1, $2 ]); 442 } 443 elsif ($lines[$l] =~ /^\s+(.*)/) { 444 $headers[$#headers]->[1] .= " ".$1 445 unless($#headers < 0); 446 } 447 $l++; 448 } 449 $attach->{'raw'} .= $lines[$l]."\n"; 450 $l++; 451 $attach->{'headers'} = \@headers; 452 foreach $h (@headers) { 453 $attach->{'header'}->{lc($h->[0])} = $h->[1]; 454 } 455 if ($attach->{'header'}->{'content-type'} =~ /^([^;\s]+)/) { 456 $attach->{'type'} = lc($1); 457 } 458 else { 459 $attach->{'type'} = 'text/plain'; 460 } 461 if ($attach->{'header'}->{'content-disposition'} =~ 462 /filename\s*=\s*"([^"]+)"/i) { 463 $attach->{'filename'} = $1; 464 } 465 elsif ($attach->{'header'}->{'content-disposition'} =~ 466 /filename\s*=\s*([^;\s]+)/i) { 467 $attach->{'filename'} = $1; 468 } 469 elsif ($attach->{'header'}->{'content-type'} =~ 470 /name\s*=\s*"([^"]+)"/i) { 471 $attach->{'filename'} = $1; 472 } 473 elsif ($attach->{'header'}->{'content-type'} =~ 474 /name\s*=\s*([^;\s]+)/i) { 475 $attach->{'filename'} = $1; 476 } 477 478 # read the attachment body 479 while($l < $max && $lines[$l] ne $bound && $lines[$l] ne "$bound--") { 480 $attach->{'data'} .= $lines[$l]."\n"; 481 $attach->{'raw'} .= $lines[$l]."\n"; 482 $l++; 483 } 484 $attach->{'data'} =~ s/\n\n$/\n/; # Lose trailing blank line 485 $attach->{'raw'} =~ s/\n\n$/\n/; 486 487 # decode if necessary 488 if (lc($attach->{'header'}->{'content-transfer-encoding'}) eq 489 'base64') { 490 # Standard base64 encoded attachment 491 $attach->{'data'} = &decode_base64($attach->{'data'}); 492 } 493 elsif (lc($attach->{'header'}->{'content-transfer-encoding'}) eq 494 'x-uue') { 495 # UUencoded attachment 496 $attach->{'data'} = &uudecode($attach->{'data'}); 497 } 498 elsif (lc($attach->{'header'}->{'content-transfer-encoding'}) eq 499 'quoted-printable') { 500 # Quoted-printable text attachment 501 $attach->{'data'} = "ed_decode($attach->{'data'}); 502 } 503 elsif (lc($attach->{'type'}) eq 'application/mac-binhex40' && &has_command("hexbin")) { 504 # Macintosh binhex encoded attachment 505 local $temp = &transname(); 506 mkdir($temp, 0700); 507 open(HEXBIN, "| (cd $temp ; hexbin -n attach -d 2>/dev/null)"); 508 print HEXBIN $attach->{'data'}; 509 close(HEXBIN); 510 if (!$?) { 511 open(HEXBIN, "<$temp/attach.data"); 512 local $/ = undef; 513 $attach->{'data'} = <HEXBIN>; 514 close(HEXBIN); 515 local $ct = &guess_mime_type($attach->{'filename'}); 516 $attach->{'type'} = $ct; 517 $attach->{'header'} = { 'content-type' => $ct }; 518 $attach->{'headers'} = [ [ 'Content-Type', $ct ] ]; 519 } 520 unlink("$temp/attach.data"); 521 rmdir($temp); 522 } 523 524 $attach->{'idx'} = scalar(@attach); 525 $attach->{'parent'} = $_[1] ? $_[1] : $_[0]; 526 push(@attach, $attach) if (@headers || $attach->{'data'}); 527 if ($attach->{'type'} =~ /multipart\/(\S+)/i) { 528 # This attachment contains more attachments .. 529 # expand them. 530 local $amail = { 'header' => $attach->{'header'}, 531 'body' => $attach->{'data'} }; 532 &parse_mail($amail, $attach, 0, $_[3]); 533 $attach->{'attach'} = [ @{$amail->{'attach'}} ]; 534 map { $_->{'idx'} += scalar(@attach) } 535 @{$amail->{'attach'}}; 536 push(@attach, @{$amail->{'attach'}}); 537 } 538 elsif (lc($attach->{'type'}) eq 'application/ms-tnef') { 539 # This attachment is a winmail.dat file, which may 540 # contain multiple other attachments! 541 local ($opentnef, $tnef); 542 if (!($opentnef = &has_command("opentnef")) && 543 !($tnef = &has_command("tnef"))) { 544 $attach->{'error'} = "tnef command not installed"; 545 } 546 else { 547 # Can actually decode 548 local $tempfile = &transname(); 549 open(TEMPFILE, ">$tempfile"); 550 print TEMPFILE $attach->{'data'}; 551 close(TEMPFILE); 552 local $tempdir = &transname(); 553 mkdir($tempdir, 0700); 554 if ($opentnef) { 555 system("$opentnef -d $tempdir -i $tempfile >/dev/null 2>&1"); 556 } 557 else { 558 system("$tnef -C $tempdir -f $tempfile >/dev/null 2>&1"); 559 } 560 pop(@attach); # lose winmail.dat 561 opendir(DIR, $tempdir); 562 while($f = readdir(DIR)) { 563 next if ($f eq '.' || $f eq '..'); 564 local $data; 565 open(FILE, "<$tempdir/$f"); 566 while(<FILE>) { 567 $data .= $_; 568 } 569 close(FILE); 570 local $ct = &guess_mime_type($f); 571 push(@attach, 572 { 'type' => $ct, 573 'idx' => scalar(@attach), 574 'header' => 575 { 'content-type' => $ct }, 576 'headers' => 577 [ [ 'Content-Type', $ct ] ], 578 'filename' => $f, 579 'data' => $data }); 580 } 581 closedir(DIR); 582 unlink(glob("$tempdir/*"), $tempfile); 583 rmdir($tempdir); 584 } 585 } 586 last if ($l >= $max || $lines[$l] eq "$bound--"); 587 $l++; 588 } 589 $_[0]->{'attach'} = \@attach; 590 } 591elsif ($_[0]->{'body'} =~ /begin\s+([0-7]+)\s+(.*)/i) { 592 # Message contains uuencoded file(s) 593 local @lines = split(/\n/, $_[0]->{'body'}); 594 local ($attach, $rest); 595 foreach $l (@lines) { 596 if ($l =~ /^begin\s+([0-7]+)\s+(.*)/i) { 597 $attach = { 'type' => &guess_mime_type($2), 598 'idx' => scalar(@{$_[0]->{'attach'}}), 599 'parent' => $_[1], 600 'filename' => $2 }; 601 push(@{$_[0]->{'attach'}}, $attach); 602 } 603 elsif ($l =~ /^end/ && $attach) { 604 $attach = undef; 605 } 606 elsif ($attach) { 607 $attach->{'data'} .= unpack("u", $l); 608 } 609 else { 610 $rest .= $l."\n"; 611 } 612 } 613 if ($rest =~ /\S/) { 614 # Some leftover text 615 push(@{$_[0]->{'attach'}}, 616 { 'type' => "text/plain", 617 'idx' => scalar(@{$_[0]->{'attach'}}), 618 'parent' => $_[1], 619 'data' => $rest }); 620 } 621 } 622elsif (lc($_[0]->{'header'}->{'content-transfer-encoding'}) eq 'base64') { 623 # Signed body section 624 $ct =~ s/;.*$//; 625 $_[0]->{'attach'} = [ { 'type' => lc($ct), 626 'idx' => 0, 627 'parent' => $_[1], 628 'data' => &decode_base64($_[0]->{'body'}) } ]; 629 } 630elsif (lc($_[0]->{'header'}->{'content-type'}) eq 'x-sun-attachment') { 631 # Sun attachment format, which can contain several sections 632 local $sun; 633 foreach $sun (split(/----------/, $_[0]->{'body'})) { 634 local ($headers, $rest) = split(/\r?\n\r?\n/, $sun, 2); 635 local $attach = { 'idx' => scalar(@{$_[0]->{'attach'}}), 636 'parent' => $_[1], 637 'data' => $rest }; 638 if ($headers =~ /X-Sun-Data-Name:\s*(\S+)/) { 639 $attach->{'filename'} = $1; 640 } 641 if ($headers =~ /X-Sun-Data-Type:\s*(\S+)/) { 642 local $st = $1; 643 $attach->{'type'} = $st eq "text" ? "text/plain" : 644 $st eq "html" ? "text/html" : 645 $st =~ /\// ? $st : "application/octet-stream"; 646 } 647 elsif ($attach->{'filename'}) { 648 $attach->{'type'} = 649 &guess_mime_type($attach->{'filename'}); 650 } 651 else { 652 $attach->{'type'} = "text/plain"; # fallback 653 } 654 push(@{$_[0]->{'attach'}}, $attach); 655 } 656 } 657else { 658 # One big attachment (probably text) 659 local ($type, $body); 660 ($type = $ct) =~ s/;.*$//; 661 $type = 'text/plain' if (!$type); 662 if (lc($_[0]->{'header'}->{'content-transfer-encoding'}) eq 'base64') { 663 $body = &decode_base64($_[0]->{'body'}); 664 } 665 elsif (lc($_[0]->{'header'}->{'content-transfer-encoding'}) eq 666 'quoted-printable') { 667 $body = "ed_decode($_[0]->{'body'}); 668 } 669 else { 670 $body = $_[0]->{'body'}; 671 } 672 if ($body =~ /\S/) { 673 $_[0]->{'attach'} = [ { 'type' => lc($type), 674 'idx' => 0, 675 'parent' => $_[1], 676 'data' => $body } ]; 677 } 678 else { 679 # Body is completely empty 680 $_[0]->{'attach'} = [ ]; 681 } 682 } 683delete($_[0]->{'body'}) if (!$_[2]); 684} 685 686# delete_mail(user|file, &mail, ...) 687# Delete mail messages from a user by copying the file and rebuilding the index 688sub delete_mail 689{ 690# Validate messages 691local @m = sort { $a->{'line'} <=> $b->{'line'} } @_[1..@_-1]; 692foreach my $m (@m) { 693 defined($m->{'line'}) && defined($m->{'eline'}) && 694 $m->{'eline'} > $m->{'line'} || 695 &error("Message to delete is invalid, perhaps to due to ". 696 "out-of-date index"); 697 } 698 699local $i = 0; 700local $f = &user_mail_file($_[0]); 701local $ifile = &user_index_file($_[0]); 702local $lnum = 0; 703local (%dline, @fline); 704local ($dpos = 0, $dlnum = 0); 705local (@index, %index); 706&build_dbm_index($_[0], \%index); 707 708local $tmpf = $< == 0 ? "$f.del" : 709 $_[0] =~ /^\/.*\/([^\/]+)$/ ? 710 "$user_module_config_directory/$1.del" : 711 "$user_module_config_directory/$_[0].del"; 712if (-l $f) { 713 $f = &resolve_links($f); 714 } 715&open_as_mail_user(SOURCE, $f) || &error("Failed to open $f : $!"); 716&create_as_mail_user(DEST, ">$tmpf") || 717 &error("Failed to open temp file $tmpf : $!"); 718while(<SOURCE>) { 719 if ($i >= @m || $lnum < $m[$i]->{'line'}) { 720 # Within a range that we want to preserve 721 $dpos += length($_); 722 $dlnum++; 723 local $w = (print DEST $_); 724 if (!$w) { 725 local $e = "$!"; 726 close(DEST); 727 close(SOURCE); 728 unlink($tmpf); 729 &error("Write to $tmpf failed : $e"); 730 } 731 } 732 elsif (!$fline[$i]) { 733 # Start line of a message to delete 734 if (!/^From\s/) { 735 # Not actually a message! Fail now 736 close(DEST); 737 close(SOURCE); 738 unlink($tmpf); 739 &error("Index on $f is corrupt - did not find expected message start at line $lnum"); 740 } 741 $fline[$i] = 1; 742 } 743 elsif ($lnum == $m[$i]->{'eline'}) { 744 # End line of the current message to delete 745 $dline{$m[$i]->{'line'}}++; 746 $i++; 747 } 748 $lnum++; 749 } 750close(SOURCE); 751close(DEST) || &error("Write to $tmpf failed : $?"); 752local @st = stat($f); 753 754# Force a total index re-build (XXX lazy!) 755$index{'mailcount'} = $in{'lastchange'} = 0; 756dbmclose(%index); 757 758if ($< == 0) { 759 # Replace the mail file with the copy 760 unlink($f); 761 rename($tmpf, $f); 762 if (!&should_switch_to_mail_user()) { 763 # Since write was done as root, set back permissions on the 764 # mail file to match the original 765 chown($st[4], $st[5], $f); 766 chmod($st[2], $f); 767 } 768 else { 769 &chmod_as_mail_user($st[2], $f); 770 } 771 } 772else { 773 system("cat ".quotemeta($tmpf)." > ".quotemeta($f). 774 " && rm -f ".quotemeta($tmpf)); 775 } 776} 777 778# modify_mail(user|file, old, new, textonly) 779# Modify one email message in a mailbox by copying the file and rebuilding 780# the index. 781sub modify_mail 782{ 783local $f = &user_mail_file($_[0]); 784local $ifile = &user_index_file($_[0]); 785local $lnum = 0; 786local ($sizediff, $linesdiff); 787local %index; 788&build_dbm_index($_[0], \%index); 789 790# Replace the email that gets modified 791local $tmpf = $< == 0 ? "$f.del" : 792 $_[0] =~ /^\/.*\/([^\/]+)$/ ? 793 "$user_module_config_directory/$1.del" : 794 "$user_module_config_directory/$_[0].del"; 795if (-l $f) { 796 $f = &resolve_links($f); 797 } 798&open_as_mail_user(SOURCE, $f) || &error("Failed to open $f : $!"); 799&create_as_mail_user(DEST, ">$tmpf") || 800 &error("Failed to open temp file $tmpf : $!"); 801while(<SOURCE>) { 802 if ($lnum < $_[1]->{'line'} || $lnum > $_[1]->{'eline'}) { 803 # before or after the message to change 804 local $w = (print DEST $_); 805 if (!$w) { 806 local $e = "$?"; 807 close(DEST); 808 close(SOURCE); 809 unlink($tmpf); 810 &error("Write to $tmpf failed : $e"); 811 } 812 } 813 elsif ($lnum == $_[1]->{'line'}) { 814 # found start of message to change .. put in the new one 815 close(DEST); 816 local @ost = stat($tmpf); 817 local $nlines = &send_mail($_[2], $tmpf, $_[3], 1); 818 local @nst = stat($tmpf); 819 local $newsize = $nst[7] - $ost[7]; 820 $sizediff = $newsize - $_[1]->{'size'}; 821 $linesdiff = $nlines - ($_[1]->{'eline'} - $_[1]->{'line'} + 1); 822 &open_as_mail_user(DEST, ">>$tmpf"); 823 } 824 $lnum++; 825 } 826close(SOURCE); 827close(DEST) || &error("Write failed : $!"); 828 829# Now update the index and delete the temp file 830for($i=0; $i<$index{'mailcount'}; $i++) { 831 local @idx = split(/\0/, $index{$i}); 832 if ($idx[1] > $_[1]->{'line'}) { 833 $idx[0] += $sizediff; 834 $idx[1] += $linesdiff; 835 $index{$i} = join("\0", @idx); 836 } 837 } 838$index{'lastchange'} = time(); 839local @st = stat($f); 840if ($< == 0) { 841 unlink($f); 842 rename($tmpf, $f); 843 if (!&should_switch_to_mail_user()) { 844 # Since write was done as root, set back permissions on the 845 # mail file to match the original 846 chown($st[4], $st[5], $f); 847 chmod($st[2], $f); 848 } 849 else { 850 &chmod_as_mail_user($st[2], $f); 851 } 852 } 853else { 854 system("cat $tmpf >$f && rm -f $tmpf"); 855 } 856chown($st[4], $st[5], $f); 857chmod($st[2], $f); 858} 859 860# send_mail(&mail, [file], [textonly], [nocr], [smtp-server], 861# [smtp-user], [smtp-pass], [smtp-auth-mode], 862# [¬ify-flags], [port], [use-ssl]) 863# Send out some email message or append it to a file. 864# Returns the number of lines written. 865sub send_mail 866{ 867local ($mail, $file, $textonly, $nocr, $sm, $user, $pass, $auth, 868 $flags, $port, $ssl) = @_; 869return 0 if (&is_readonly_mode()); 870local $lnum = 0; 871$sm ||= $config{'send_mode'}; 872local $eol = $nocr || !$sm ? "\n" : "\r\n"; 873$ssl = $config{'smtp_ssl'} if ($ssl eq ''); 874local $defport = $ssl == 1 ? 465 : 25; 875$port ||= $config{'smtp_port'} || $defport; 876my %header; 877foreach my $head (@{$mail->{'headers'}}) { 878 $header{lc($head->[0])} = $head->[1]; 879 } 880 881# Add the date header, always in english 882&clear_time_locale(); 883local @tm = localtime(time()); 884push(@{$mail->{'headers'}}, 885 [ 'Date', strftime("%a, %d %b %Y %H:%M:%S %z (%Z)", @tm) ]) 886 if (!$header{'date'}); 887&reset_time_locale(); 888 889# Build list of destination email addresses 890my @dests; 891foreach my $f ("to", "cc", "bcc") { 892 if ($header{$f}) { 893 push(@dests, &address_parts($header{$f})); 894 } 895 } 896my $qdests = join(" ", map { quotemeta($_) } @dests); 897 898local @from = &address_parts($header{'from'}); 899local $fromaddr; 900if (@from && $from[0] =~ /\S/) { 901 $fromaddr = $from[0]; 902 } 903else { 904 local @uinfo = getpwuid($<); 905 $fromaddr = $uinfo[0] || "nobody"; 906 $fromaddr .= '@'.&get_system_hostname(); 907 } 908local $qfromaddr = quotemeta($fromaddr); 909local $esmtp = $flags ? 1 : 0; 910my $h = { 'fh' => 'mailboxes::MAIL' }; 911if ($file) { 912 # Just append the email to a file using mbox format 913 &open_as_mail_user($h->{'fh'}, ">>$file") || 914 &error("Write failed : $!"); 915 $lnum++; 916 &write_http_connection($h, 917 $mail->{'fromline'} ? $mail->{'fromline'}.$eol : 918 &make_from_line($fromaddr).$eol); 919 } 920elsif ($sm) { 921 # Connect to SMTP server 922 &open_socket($sm, $port, $h->{'fh'}); 923 if ($ssl == 1) { 924 # Start using SSL mode right away 925 &switch_smtp_to_ssl($h); 926 } 927 928 &smtp_command($h, undef, 0); 929 my $helo = $config{'helo_name'} || &get_system_hostname(); 930 if ($esmtp) { 931 &smtp_command($h, "ehlo $helo\r\n", 0); 932 } 933 else { 934 &smtp_command($h, "helo $helo\r\n", 0); 935 } 936 937 if ($ssl == 2) { 938 # Switch to SSL with STARTTLS, if possible 939 my $rv = &smtp_command($h, "starttls\r\n", 1); 940 if ($rv =~ /^2\d+/) { 941 &switch_smtp_to_ssl($h); 942 } 943 else { 944 $ssl = 0; 945 } 946 } 947 948 # Get username and password from parameters, or from module config 949 $user ||= $userconfig{'smtp_user'} || $config{'smtp_user'}; 950 $pass ||= $userconfig{'smtp_pass'} || $config{'smtp_pass'}; 951 $auth ||= $userconfig{'smtp_auth'} || 952 $config{'smtp_auth'} || "Cram-MD5"; 953 if ($user) { 954 # Send authentication commands 955 eval "use Authen::SASL"; 956 if ($@) { 957 &error("Perl module <tt>Authen::SASL</tt> is needed for SMTP authentication"); 958 } 959 my $sasl = Authen::SASL->new('mechanism' => uc($auth), 960 'callback' => { 961 'auth' => $user, 962 'user' => $user, 963 'pass' => $pass } ); 964 &error("Failed to create Authen::SASL object") if (!$sasl); 965 local $conn = $sasl->client_new("smtp", &get_system_hostname()); 966 local $arv = &smtp_command($h, "auth $auth\r\n", 1); 967 if ($arv =~ /^(334)(\-\S+)?\s+(.*)/) { 968 # Server says to go ahead 969 $extra = $3; 970 local $initial = $conn->client_start(); 971 local $auth_ok; 972 if ($initial) { 973 local $enc = &encode_base64($initial); 974 $enc =~ s/\r|\n//g; 975 $arv = &smtp_command($h, "$enc\r\n", 1); 976 if ($arv =~ /^(\d+)(\-\S+)?\s+(.*)/) { 977 if ($1 == 235) { 978 $auth_ok = 1; 979 } 980 else { 981 &error("Unknown SMTP authentication response : $arv"); 982 } 983 } 984 $extra = $3; 985 } 986 while(!$auth_ok) { 987 local $message = &decode_base64($extra); 988 local $return = $conn->client_step($message); 989 local $enc = &encode_base64($return); 990 $enc =~ s/\r|\n//g; 991 $arv = &smtp_command($h, "$enc\r\n", 1); 992 if ($arv =~ /^(\d+)(\-\S+)?\s+(.*)/) { 993 if ($1 == 235) { 994 $auth_ok = 1; 995 } 996 elsif ($1 == 535) { 997 &error("SMTP authentication failed : $arv"); 998 } 999 $extra = $3; 1000 } 1001 else { 1002 &error("Unknown SMTP authentication response : $arv"); 1003 } 1004 } 1005 } 1006 } 1007 1008 &smtp_command($h, "mail from: <$fromaddr>\r\n", 0); 1009 local $notify = $flags ? " NOTIFY=".join(",", @$flags) : ""; 1010 foreach my $u (@dests) { 1011 &smtp_command($h, "rcpt to: <$u>$notify\r\n", 0); 1012 } 1013 &smtp_command($h, "data\r\n", 0); 1014 } 1015elsif (defined(&send_mail_program)) { 1016 # Use specified mail injector 1017 local $cmd = &send_mail_program($fromaddr, \@dests); 1018 $cmd || &error("No mail program was found on your system!"); 1019 open($h->{'fh'}, "| $cmd >/dev/null 2>&1"); 1020 } 1021elsif ($config{'qmail_dir'}) { 1022 # Start qmail-inject 1023 open($h->{'fh'}, "| $config{'qmail_dir'}/bin/qmail-inject"); 1024 } 1025elsif ($config{'postfix_control_command'}) { 1026 # Start postfix's sendmail wrapper 1027 local $cmd = -x "/usr/lib/sendmail" ? "/usr/lib/sendmail" : 1028 &has_command("sendmail"); 1029 $cmd || &error($text{'send_ewrapper'}); 1030 open($h->{'fh'}, "| $cmd -f$qfromaddr $qdests >/dev/null 2>&1"); 1031 } 1032else { 1033 # Start sendmail 1034 &has_command($config{'sendmail_path'}) || 1035 &error(&text('send_epath', "<tt>$config{'sendmail_path'}</tt>")); 1036 open($h->{'fh'}, "| $config{'sendmail_path'} -f$qfromaddr $qdests >/dev/null 2>&1"); 1037 } 1038 1039local $ctype = "multipart/mixed"; 1040local $msg_id; 1041foreach $head (@{$mail->{'headers'}}) { 1042 if (defined($mail->{'body'}) || $textonly) { 1043 &write_http_connection($h, $head->[0],": ",$head->[1],$eol); 1044 $lnum++; 1045 } 1046 else { 1047 if ($head->[0] !~ /^(MIME-Version|Content-Type)$/i) { 1048 &write_http_connection($h, $head->[0],": ",$head->[1],$eol); 1049 $lnum++; 1050 } 1051 elsif (lc($head->[0]) eq 'content-type') { 1052 $ctype = $head->[1]; 1053 } 1054 } 1055 if (lc($head->[0]) eq 'message-id') { 1056 $msg_id++; 1057 } 1058 } 1059if (!$msg_id) { 1060 # Add a message-id header if missing 1061 $main::mailboxes_message_id_count++; 1062 &write_http_connection($h, "Message-Id: <",time().".".$$.".". 1063 $main::mailboxes_message_id_count."\@". 1064 &get_system_hostname(),">",$eol); 1065 } 1066 1067# Work out first attachment content type 1068local ($ftype, $fenc); 1069if (@{$mail->{'attach'}} >= 1) { 1070 local $first = $mail->{'attach'}->[0]; 1071 $ftype = "text/plain"; 1072 foreach my $h (@{$first->{'headers'}}) { 1073 if (lc($h->[0]) eq "content-type") { 1074 $ftype = $h->[1]; 1075 } 1076 if (lc($h->[0]) eq "content-transfer-encoding") { 1077 $fenc = $h->[1]; 1078 } 1079 } 1080 } 1081 1082if (defined($mail->{'body'})) { 1083 # Use original mail body 1084 &write_http_connection($h, $eol); 1085 $lnum++; 1086 $mail->{'body'} =~ s/\r//g; 1087 $mail->{'body'} =~ s/\n\.\n/\n\. \n/g; 1088 $mail->{'body'} =~ s/\n/$eol/g; 1089 $mail->{'body'} .= $eol if ($mail->{'body'} !~ /\n$/); 1090 &write_http_connection($h, $mail->{'body'}) || &error("Write failed : $!"); 1091 $lnum += ($mail->{'body'} =~ tr/\n/\n/); 1092 } 1093elsif (!@{$mail->{'attach'}}) { 1094 # No content, so just send empty email 1095 &write_http_connection($h, "Content-Type: text/plain",$eol); 1096 &write_http_connection($h, $eol); 1097 $lnum += 2; 1098 } 1099elsif (!$textonly || $ftype !~ /text\/plain/i || 1100 $fenc =~ /quoted-printable|base64/) { 1101 # Sending MIME-encoded email 1102 if ($ctype !~ /multipart\/report/i) { 1103 $ctype =~ s/;.*$//; 1104 } 1105 &write_http_connection($h, "MIME-Version: 1.0",$eol); 1106 local $bound = "bound".time(); 1107 &write_http_connection($h, "Content-Type: $ctype; boundary=\"$bound\"",$eol); 1108 &write_http_connection($h, $eol); 1109 $lnum += 3; 1110 1111 # Send attachments 1112 &write_http_connection($h, "This is a multi-part message in MIME format.",$eol); 1113 $lnum++; 1114 foreach $a (@{$mail->{'attach'}}) { 1115 &write_http_connection($h, $eol); 1116 &write_http_connection($h, "--",$bound,$eol); 1117 $lnum += 2; 1118 local $enc; 1119 foreach $head (@{$a->{'headers'}}) { 1120 &write_http_connection($h, $head->[0],": ",$head->[1],$eol); 1121 $enc = $head->[1] 1122 if (lc($head->[0]) eq 'content-transfer-encoding'); 1123 $lnum++; 1124 } 1125 &write_http_connection($h, $eol); 1126 $lnum++; 1127 if (lc($enc) eq 'base64') { 1128 local $enc = &encode_base64($a->{'data'}); 1129 $enc =~ s/\r//g; 1130 $enc =~ s/\n/$eol/g; 1131 &write_http_connection($h, $enc); 1132 $lnum += ($enc =~ tr/\n/\n/); 1133 } 1134 else { 1135 $a->{'data'} =~ s/\r//g; 1136 $a->{'data'} =~ s/\n\.\n/\n\. \n/g; 1137 $a->{'data'} =~ s/\n/$eol/g; 1138 &write_http_connection($h, $a->{'data'}); 1139 $lnum += ($a->{'data'} =~ tr/\n/\n/); 1140 if ($a->{'data'} !~ /\n$/) { 1141 &write_http_connection($h, $eol); 1142 $lnum++; 1143 } 1144 } 1145 } 1146 &write_http_connection($h, $eol); 1147 &write_http_connection($h, "--",$bound,"--",$eol) || 1148 &error("Write failed : $!"); 1149 &write_http_connection($h, $eol); 1150 $lnum += 3; 1151 } 1152else { 1153 # Sending text-only mail from first attachment 1154 local $a = $mail->{'attach'}->[0]; 1155 &write_http_connection($h, $eol); 1156 $lnum++; 1157 $a->{'data'} =~ s/\r//g; 1158 $a->{'data'} =~ s/\n/$eol/g; 1159 &write_http_connection($h, $a->{'data'}) || &error("Write failed : $!"); 1160 $lnum += ($a->{'data'} =~ tr/\n/\n/); 1161 if ($a->{'data'} !~ /\n$/) { 1162 &write_http_connection($h, $eol); 1163 $lnum++; 1164 } 1165 } 1166if ($sm && !$file) { 1167 &smtp_command($h, ".$eol", 0); 1168 &smtp_command($h, "quit$eol", 0); 1169 } 1170if (!&close_http_connection($h)) { 1171 # Only bother to report an error on close if writing to a file 1172 if ($file) { 1173 &error("Write failed : $!"); 1174 } 1175 } 1176return $lnum; 1177} 1178 1179# switch_smtp_to_ssl(&handle) 1180# Switch an SMTP connection handle to SSL mode 1181sub switch_smtp_to_ssl 1182{ 1183my ($h) = @_; 1184eval "use Net::SSLeay"; 1185$@ && &error($text{'link_essl'}); 1186eval "Net::SSLeay::SSLeay_add_ssl_algorithms()"; 1187eval "Net::SSLeay::load_error_strings()"; 1188$h->{'ssl_ctx'} = Net::SSLeay::CTX_new() || 1189 &error("Failed to create SSL context"); 1190$h->{'ssl_con'} = Net::SSLeay::new($h->{'ssl_ctx'}) || 1191 &error("Failed to create SSL connection"); 1192Net::SSLeay::set_fd($h->{'ssl_con'}, fileno($h->{'fh'})); 1193Net::SSLeay::connect($h->{'ssl_con'}) || 1194 &error("SSL connect() failed"); 1195} 1196 1197# unparse_mail(&attachments, eol, boundary) 1198# Convert an array of attachments into MIME format, and return them as an 1199# array of lines. 1200sub unparse_mail 1201{ 1202local ($attach, $eol, $bound) = @_; 1203local @rv; 1204foreach my $a (@$attach) { 1205 push(@rv, $eol); 1206 push(@rv, "--".$bound.$eol); 1207 local $enc; 1208 foreach my $h (@{$a->{'headers'}}) { 1209 push(@rv, $h->[0].": ".$h->[1].$eol); 1210 $enc = $h->[1] 1211 if (lc($h->[0]) eq 'content-transfer-encoding'); 1212 } 1213 push(@rv, $eol); 1214 if (lc($enc) eq 'base64') { 1215 local $enc = &encode_base64($a->{'data'}); 1216 $enc =~ s/\r//g; 1217 foreach my $l (split(/\n/, $enc)) { 1218 push(@rv, $l.$eol); 1219 } 1220 } 1221 else { 1222 $a->{'data'} =~ s/\r//g; 1223 $a->{'data'} =~ s/\n\.\n/\n\. \n/g; 1224 foreach my $l (split(/\n/, $a->{'data'})) { 1225 push(@rv, $l.$eol); 1226 } 1227 } 1228 } 1229push(@rv, $eol); 1230push(@rv, "--".$bound."--".$eol); 1231push(@rv, $eol); 1232return @rv; 1233} 1234 1235# mail_size(&mail, [textonly]) 1236# Returns the size of an email message in bytes 1237sub mail_size 1238{ 1239local ($mail, $textonly) = @_; 1240local $temp = &transname(); 1241&send_mail($mail, $temp, $textonly); 1242local @st = stat($temp); 1243unlink($temp); 1244return $st[7]; 1245} 1246 1247# can_read_mail(user) 1248sub can_read_mail 1249{ 1250return 1 if ($_[0] && $access{'sent'} eq $_[0]); 1251local @u = getpwnam($_[0]); 1252return 0 if (!@u); 1253return 0 if ($_[0] =~ /\.\./); 1254return 0 if ($access{'mmode'} == 0); 1255return 1 if ($access{'mmode'} == 1); 1256local $u; 1257if ($access{'mmode'} == 2) { 1258 foreach $u (split(/\s+/, $access{'musers'})) { 1259 return 1 if ($u eq $_[0]); 1260 } 1261 return 0; 1262 } 1263elsif ($access{'mmode'} == 4) { 1264 return 1 if ($_[0] eq $remote_user); 1265 } 1266elsif ($access{'mmode'} == 5) { 1267 return $u[3] eq $access{'musers'}; 1268 } 1269elsif ($access{'mmode'} == 3) { 1270 foreach $u (split(/\s+/, $access{'musers'})) { 1271 return 0 if ($u eq $_[0]); 1272 } 1273 return 1; 1274 } 1275elsif ($access{'mmode'} == 6) { 1276 return ($_[0] =~ /^$access{'musers'}$/); 1277 } 1278elsif ($access{'mmode'} == 7) { 1279 return (!$access{'musers'} || $u[2] >= $access{'musers'}) && 1280 (!$access{'musers2'} || $u[2] <= $access{'musers2'}); 1281 } 1282return 0; # can't happen! 1283} 1284 1285# from_hostname() 1286sub from_hostname 1287{ 1288local ($d, $masq); 1289local $conf = &get_sendmailcf(); 1290foreach $d (&find_type("D", $conf)) { 1291 if ($d->{'value'} =~ /^M\s*(\S*)/) { $masq = $1; } 1292 } 1293return $masq ? $masq : &get_system_hostname(); 1294} 1295 1296# mail_from_queue(qfile, [dfile|"auto"]) 1297# Reads a message from the Sendmail mail queue 1298sub mail_from_queue 1299{ 1300local $mail = { 'file' => $_[0] }; 1301$mail->{'quar'} = $_[0] =~ /\/hf/; 1302$mail->{'lost'} = $_[0] =~ /\/Qf/; 1303if ($_[1] eq "auto") { 1304 $mail->{'dfile'} = $_[0]; 1305 $mail->{'dfile'} =~ s/\/(qf|hf|Qf)/\/df/; 1306 } 1307elsif ($_[1]) { 1308 $mail->{'dfile'} = $_[1]; 1309 } 1310$mail->{'lfile'} = $_[0]; 1311$mail->{'lfile'} =~ s/\/(qf|hf|Qf)/\/xf/; 1312local $_; 1313local @headers; 1314open(QF, "<", $_[0]) || return undef; 1315while(<QF>) { 1316 s/\r|\n//g; 1317 if (/^M(.*)/) { 1318 $mail->{'status'} = $1; 1319 } 1320 elsif (/^H\?[^\?]*\?(\S+):\s+(.*)/ || /^H(\S+):\s+(.*)/) { 1321 push(@headers, [ $1, $2 ]); 1322 $mail->{'rawheaders'} .= "$1: $2\n"; 1323 } 1324 elsif (/^\s+(.*)/) { 1325 $headers[$#headers]->[1] .= $1 unless($#headers < 0); 1326 $mail->{'rawheaders'} .= $_."\n"; 1327 } 1328 } 1329close(QF); 1330$mail->{'headers'} = \@headers; 1331foreach $h (@headers) { 1332 $mail->{'header'}->{lc($h->[0])} = $h->[1]; 1333 } 1334 1335if ($mail->{'dfile'}) { 1336 # Read the mail body 1337 open(DF, "<", $mail->{'dfile'}); 1338 while(<DF>) { 1339 $mail->{'body'} .= $_; 1340 } 1341 close(DF); 1342 } 1343local $datafile = $mail->{'dfile'}; 1344if (!$datafile) { 1345 ($datafile = $mail->{'file'}) =~ s/\/(qf|hf|Qf)/\/df/; 1346 } 1347local @st0 = stat($mail->{'file'}); 1348local @st1 = stat($datafile); 1349$mail->{'size'} = $st0[7] + $st1[7]; 1350return $mail; 1351} 1352 1353# wrap_lines(text, width) 1354# Given a multi-line string, return an array of lines wrapped to 1355# the given width 1356sub wrap_lines 1357{ 1358local @rv; 1359local $w = $_[1]; 1360foreach $rest (split(/\n/, $_[0])) { 1361 if ($rest =~ /\S/) { 1362 while($rest =~ /^(.{1,$w}\S*)\s*([\0-\377]*)$/) { 1363 push(@rv, $1); 1364 $rest = $2; 1365 } 1366 } 1367 else { 1368 # Empty line .. keep as it is 1369 push(@rv, $rest); 1370 } 1371 } 1372return @rv; 1373} 1374 1375# smtp_command(&handle, command, no-error) 1376# Send a single SMTP command to some file handle, and read back the response 1377sub smtp_command 1378{ 1379my ($h, $c, $noerr) = @_; 1380if ($c) { 1381 &write_http_connection($h, $c); 1382 } 1383my $r = &read_http_connection($h); 1384if ($r !~ /^[23]\d+/ && !$noerr) { 1385 $c =~ s/\r|\n//g; 1386 &error(&text('send_esmtp', "<tt>".&html_escape($c)."</tt>", 1387 "<tt>".&html_escape($r)."</tt>")); 1388 } 1389$r =~ s/\r|\n//g; 1390if ($r =~ /^(\d+)\-/) { 1391 # multi-line ESMTP response! 1392 while(1) { 1393 my $nr = &read_http_connection($h); 1394 $nr =~ s/\r|\n//g; 1395 if ($nr =~ /^(\d+)\-(.*)/) { 1396 $r .= "\n".$2; 1397 } 1398 elsif ($nr =~ /^(\d+)\s+(.*)/) { 1399 $r .= "\n".$2; 1400 last; 1401 } 1402 } 1403 } 1404return $r; 1405} 1406 1407# address_parts(string) 1408# Returns the email addresses in a string 1409sub address_parts 1410{ 1411local @rv = map { $_->[0] } &split_addresses($_[0]); 1412return wantarray ? @rv : $rv[0]; 1413} 1414 1415# link_urls(text, separate) 1416# Converts URLs into HTML links 1417sub link_urls 1418{ 1419local $r = $_[0]; 1420local $tar = $_[1] ? "target=_blank" : ""; 1421$r =~ s/((http|ftp|https|mailto):[^><"'\s]+[^><"'\s\.\)])/<a href="$1" $tar>$1<\/a>/g; 1422return $r; 1423} 1424 1425# link_urls_and_escape(text, separate) 1426# HTML escapes some text, as well as properly linking URLs in it 1427sub link_urls_and_escape 1428{ 1429local $l = $_[0]; 1430local $rv; 1431local $tar = $_[1] ? " target=_blank" : ""; 1432while($l =~ /^(.*?)((http|ftp|https|mailto):[^><"'\s]+[^><"'\s\.\)])(.*)/) { 1433 local ($before, $url, $after) = ($1, $2, $4); 1434 $rv .= &eucconv_and_escape($before)."<a href='$url' $tar>". 1435 &html_escape($url)."</a>"; 1436 $l = $after; 1437 } 1438$rv .= &eucconv_and_escape($l); 1439return $rv; 1440} 1441 1442# links_urls_new_target(html) 1443# Converts any links without targets to open in a new window 1444sub links_urls_new_target 1445{ 1446local $l = $_[0]; 1447local $rv; 1448while($l =~ s/^([\0-\377]*?)<\s*a\s+([^>]*href[^>]*)>//i) { 1449 local ($before, $a) = ($1, $2); 1450 if ($a !~ /target\s*=/i) { 1451 $a .= " target=_blank"; 1452 } 1453 $rv .= $before."<a ".$a.">"; 1454 } 1455$rv .= $l; 1456return $rv; 1457} 1458 1459# uudecode(text) 1460sub uudecode 1461{ 1462local @lines = split(/\n/, $_[0]); 1463local ($l, $data); 1464for($l=0; $lines[$l] !~ /begin\s+([0-7]+)\s/i; $l++) { } 1465while($lines[++$l]) { 1466 $data .= unpack("u", $lines[$l]); 1467 } 1468return $data; 1469} 1470 1471# simplify_date(datestring, [format]) 1472# Given a date from an email header, convert to the user's preferred format 1473sub simplify_date 1474{ 1475local ($date, $fmt) = @_; 1476local $u = &parse_mail_date($date); 1477if ($u) { 1478 $fmt ||= $userconfig{'date_fmt'} || $config{'date_fmt'} || "dmy"; 1479 local $strf = $fmt eq "dmy" ? "%d/%m/%Y" : 1480 $fmt eq "mdy" ? "%m/%d/%Y" : 1481 "%Y/%m/%d"; 1482 return strftime("$strf %H:%M", localtime($u)); 1483 } 1484elsif ($date =~ /^(\S+),\s+0*(\d+)\s+(\S+)\s+(\d+)\s+(\d+):(\d+)/) { 1485 return "$2/$3/$4 $5:$6"; 1486 } 1487elsif ($date =~ /^0*(\d+)\s+(\S+)\s+(\d+)\s+(\d+):(\d+)/) { 1488 return "$1/$2/$3 $4:$5"; 1489 } 1490return $date; 1491} 1492 1493# simplify_from(from) 1494# Simplifies a From: address for display in the mail list. Only the first 1495# address is returned. 1496sub simplify_from 1497{ 1498local $rv = &convert_header_for_display($_[0], 0, 1); 1499local @sp = &split_addresses($rv); 1500if (!@sp) { 1501 return $text{'mail_nonefrom'}; 1502 } 1503else { 1504 local $first = &html_escape($sp[0]->[1] ? $sp[0]->[1] : $sp[0]->[2]); 1505 if (length($first) > 80) { 1506 return substr($first, 0, 80)." .."; 1507 } 1508 else { 1509 return $first.(@sp > 1 ? " , ..." : ""); 1510 } 1511 } 1512} 1513 1514# convert_header_for_display(string, [max-non-html-length], [no-escape]) 1515# Given a string from an email header, perform all mime-decoding, charset 1516# changes and HTML escaping needed to render it in a browser 1517sub convert_header_for_display 1518{ 1519local ($str, $max, $noescape) = @_; 1520local ($mw, $cs) = &decode_mimewords($str); 1521if (&get_charset() eq 'UTF-8' && &can_convert_to_utf8($mw, $cs)) { 1522 $mw = &convert_to_utf8($mw, $cs); 1523 } 1524local $rv = &eucconv($mw); 1525$rv = substr($rv, 0, $max)." .." if ($max && length($rv) > $max); 1526return $noescape ? $rv : &html_escape($rv); 1527} 1528 1529# simplify_subject(subject) 1530# Simplifies and truncates a subject header for display in the mail list 1531sub simplify_subject 1532{ 1533return &convert_header_for_display($_[0], 80); 1534} 1535 1536# quoted_decode(text) 1537# Converts quoted-printable format to the original 1538sub quoted_decode 1539{ 1540local $t = $_[0]; 1541$t =~ s/[ \t]+?(\r?\n)/$1/g; 1542$t =~ s/=\r?\n//g; 1543$t =~ s/(^|[^\r])\n\Z/$1\r\n/; 1544$t =~ s/=([a-fA-F0-9]{2})/pack("c",hex($1))/ge; 1545return $t; 1546} 1547 1548# quoted_encode(text) 1549# Encodes text to quoted-printable format 1550sub quoted_encode 1551{ 1552local $t = $_[0]; 1553$t =~ s/([=\177-\377])/sprintf("=%2.2X",ord($1))/ge; 1554return $t; 1555} 1556 1557# decode_mimewords(string) 1558# Converts a string in MIME words format like 1559# =?ISO-8859-1?Q?Keld_J=F8rn_Simonsen?= to actual 8-bit characters 1560sub decode_mimewords { 1561 my $encstr = shift; 1562 my %params = @_; 1563 my @tokens; 1564 $@ = ''; ### error-return 1565 1566 ### Collapse boundaries between adjacent encoded words: 1567 $encstr =~ s{(\?\=)\r?\n[ \t](\=\?)}{$1$2}gs; 1568 pos($encstr) = 0; 1569 ### print STDOUT "ENC = [", $encstr, "]\n"; 1570 1571 ### Decode: 1572 my ($charset, $encoding, $enc, $dec); 1573 while (1) { 1574 last if (pos($encstr) >= length($encstr)); 1575 my $pos = pos($encstr); ### save it 1576 1577 ### Case 1: are we looking at "=?..?..?="? 1578 if ($encstr =~ m{\G # from where we left off.. 1579 =\?([^?]*) # "=?" + charset + 1580 \?([bq]) # "?" + encoding + 1581 \?([^?]+) # "?" + data maybe with spcs + 1582 \?= # "?=" 1583 }xgi) { 1584 ($charset, $encoding, $enc) = ($1, lc($2), $3); 1585 $dec = (($encoding eq 'q') ? _decode_Q($enc) : _decode_B($enc)); 1586 push @tokens, [$dec, $charset]; 1587 next; 1588 } 1589 1590 ### Case 2: are we looking at a bad "=?..." prefix? 1591 ### We need this to detect problems for case 3, which stops at "=?": 1592 pos($encstr) = $pos; # reset the pointer. 1593 if ($encstr =~ m{\G=\?}xg) { 1594 $@ .= qq|unterminated "=?..?..?=" in "$encstr" (pos $pos)\n|; 1595 push @tokens, ['=?']; 1596 next; 1597 } 1598 1599 ### Case 3: are we looking at ordinary text? 1600 pos($encstr) = $pos; # reset the pointer. 1601 if ($encstr =~ m{\G # from where we left off... 1602 ([\x00-\xFF]*? # shortest possible string, 1603 \n*) # followed by 0 or more NLs, 1604 (?=(\Z|=\?)) # terminated by "=?" or EOS 1605 }xg) { 1606 length($1) or die "MIME::Words: internal logic err: empty token\n"; 1607 push @tokens, [$1]; 1608 next; 1609 } 1610 1611 ### Case 4: bug! 1612 die "MIME::Words: unexpected case:\n($encstr) pos $pos\n\t". 1613 "Please alert developer.\n"; 1614 } 1615 if (wantarray) { 1616 return (join('',map {$_->[0]} @tokens), $charset); 1617 } else { 1618 return join('',map {$_->[0]} @tokens); 1619 } 1620} 1621 1622# _decode_Q STRING 1623# Private: used by _decode_header() to decode "Q" encoding, which is 1624# almost, but not exactly, quoted-printable. :-P 1625sub _decode_Q { 1626 my $str = shift; 1627 $str =~ s/_/\x20/g; # RFC-1522, Q rule 2 1628 $str =~ s/=([\da-fA-F]{2})/pack("C", hex($1))/ge; # RFC-1522, Q rule 1 1629 $str; 1630} 1631 1632# _decode_B STRING 1633# Private: used by _decode_header() to decode "B" encoding. 1634sub _decode_B { 1635 my $str = shift; 1636 &decode_base64($str); 1637} 1638 1639# encode_mimewords(string, %params) 1640# Converts a word with 8-bit characters to MIME words format 1641sub encode_mimewords 1642{ 1643my ($rawstr, %params) = @_; 1644my $charset = 'UTF-8'; 1645my $defenc = 'q'; 1646my $encoding = lc($params{Encoding} || $defenc); 1647my $NONPRINT = "\\x00-\\x1F\\x7F-\\xFF"; 1648 1649if ($rawstr =~ /^[\x20-\x7E]*$/) { 1650 # No encoding needed 1651 return $rawstr; 1652 } 1653 1654### Encode any "words" with unsafe characters. 1655### We limit such words to 18 characters, to guarantee that the 1656### worst-case encoding give us no more than 54 + ~10 < 75 characters 1657my $word; 1658$rawstr =~ s{([ a-zA-Z0-9\x7F-\xFF]{1,18})}{ ### get next "word" 1659 $word = $1; 1660 $word =~ /(?:[$NONPRINT])|(?:^\s+$)/o ? 1661 encode_mimeword($word, $encoding, $charset) : # unsafe chars 1662 $word # OK word 1663}xeg; 1664$rawstr =~ s/\?==\?/?= =?/g; 1665return $rawstr; 1666} 1667 1668# can_convert_to_utf8(string, string-charset) 1669# Check if the appropriate perl modules are available for UTF-8 conversion 1670sub can_convert_to_utf8 1671{ 1672my ($str, $cs) = @_; 1673return 0 if ($cs eq "UTF-8"); 1674return 0 if (!$cs); 1675eval "use Encode"; 1676return 0 if ($@); 1677eval "use utf8"; 1678return 0 if ($@); 1679return 1; 1680} 1681 1682# convert_to_utf8(string, string-charset) 1683# If possible, convert a string to the UTF-8 charset 1684sub convert_to_utf8 1685{ 1686my ($str, $cs) = @_; 1687&can_convert_to_utf8(@_); # Load modules 1688eval { 1689 $str = Encode::decode($cs, $str); 1690 utf8::encode($str); 1691 }; 1692return $str; 1693} 1694 1695# decode_utf7(string) 1696# If possible, convert a string like `Gel&APY-schte` to `Gelöschte` 1697# It will also convert complex strings like `Gel&APY-schte & Spam` 1698sub decode_utf7 1699{ 1700my ($a) = @_; 1701eval "use Encode"; 1702return $a if ($@); 1703my $u = find_encoding("UTF-16BE"); 1704return $a if (!$u); 1705my $s = ' '; 1706my @a = split($s, $a); 1707my @b; 1708foreach my $c (@a) { 1709 my $b; 1710 # Based on Encode::Unicode::UTF7 by Dan Kogai 1711 while (pos($c) < length($c)) { 1712 if ($c =~ /\G([^&]+)/ogc) { 1713 $b .= "$1"; 1714 } 1715 elsif ($c =~ /\G\&-/ogc) { 1716 $b .= "&"; 1717 } 1718 elsif ($c =~ /\G\&([A-Za-z0-9+,]+)-?/ogsc) { 1719 my $d = $1; 1720 $d =~ s/,/\//g; 1721 my $p = length($d) % 4; 1722 $d .= "=" x (4 - $p) if ($p); 1723 $b .= $u->decode(decode_base64($d)); 1724 } 1725 elsif ($c =~ /\G\&/ogc) { 1726 $b = $c; 1727 } 1728 else { 1729 return $a; 1730 } 1731 } 1732 push(@b, $b); 1733 } 1734return join($s, @b); 1735} 1736 1737# encode_mimewords_address(string, %params) 1738# Given a string containing addresses into one with real names mime-words 1739# escaped 1740sub encode_mimewords_address 1741{ 1742my ($rawstr, %params) = @_; 1743my $charset = 'UTF-8'; 1744my $defenc = 'q'; 1745my $encoding = lc($params{Encoding} || $defenc); 1746if ($rawstr =~ /^[\x20-\x7E]*$/) { 1747 # No encoding needed 1748 return $rawstr; 1749 } 1750my @rv; 1751foreach my $addr (&split_addresses($rawstr)) { 1752 my ($email, $name, $orig) = @$addr; 1753 if ($name =~ /^[\x20-\x7E]*$/) { 1754 # No encoding needed 1755 push(@rv, $orig); 1756 } 1757 else { 1758 # Re-encode name 1759 my $ename = encode_mimeword($name, $encoding, $charset); 1760 push(@rv, $ename." <".$email.">"); 1761 } 1762 } 1763return join(", ", @rv); 1764} 1765 1766# encode_mimeword(string, [encoding], [charset]) 1767# Converts a word with 8-bit characters to MIME words format 1768sub encode_mimeword 1769{ 1770my $word = shift; 1771my $encoding = uc(shift || 'Q'); 1772my $charset = 'UTF-8'; 1773my $encfunc = (($encoding eq 'Q') ? \&_encode_Q : \&_encode_B); 1774return "=?$charset?$encoding?" . &$encfunc($word) . "?="; 1775} 1776 1777# _encode_Q STRING 1778# Private: used by _encode_header() to decode "Q" encoding, which is 1779# almost, but not exactly, quoted-printable. :-P 1780sub _encode_Q { 1781 my $str = shift; 1782 my $NONPRINT = "\\x00-\\x1F\\x7F-\\xFF"; 1783 $str =~ s{([ _\?\=$NONPRINT])}{sprintf("=%02X", ord($1))}eog; 1784 return $str; 1785} 1786 1787# _encode_B STRING 1788# Private: used by _decode_header() to decode "B" encoding. 1789sub _encode_B { 1790 my $str = shift; 1791 my $enc = &encode_base64($str); 1792 $enc =~ s/\n//; 1793 return $enc; 1794} 1795 1796# user_mail_file(user|file, [other details]) 1797sub user_mail_file 1798{ 1799if ($_[0] =~ /^\//) { 1800 return $_[0]; 1801 } 1802elsif ($config{'mail_dir'}) { 1803 return &mail_file_style($_[0], $config{'mail_dir'}, 1804 $config{'mail_style'}); 1805 } 1806elsif (@_ > 1) { 1807 return "$_[7]/$config{'mail_file'}"; 1808 } 1809else { 1810 local @u = getpwnam($_[0]); 1811 return "$u[7]/$config{'mail_file'}"; 1812 } 1813} 1814 1815# mail_file_style(user, basedir, style) 1816# Given a directory and username, returns the path to that user's mail file 1817# under the directory based on the style (which may force use of parts of 1818# the username). 1819sub mail_file_style 1820{ 1821if ($_[2] == 0) { 1822 return "$_[1]/$_[0]"; 1823 } 1824elsif ($_[2] == 1) { 1825 return $_[1]."/".substr($_[0], 0, 1)."/".$_[0]; 1826 } 1827elsif ($_[2] == 2) { 1828 return $_[1]."/".substr($_[0], 0, 1)."/". 1829 substr($_[0], 0, 2)."/".$_[0]; 1830 } 1831else { 1832 return $_[1]."/".substr($_[0], 0, 1)."/". 1833 substr($_[0], 1, 1)."/".$_[0]; 1834 } 1835} 1836 1837# user_index_file(user|file) 1838sub user_index_file 1839{ 1840local $us = $_[0]; 1841$us =~ s/\//_/g; 1842local $f; 1843local $hn = &get_system_hostname(); 1844if ($_[0] =~ /^\/.*\/([^\/]+)$/) { 1845 # A file .. the index file is in ~/.usermin/mailbox or 1846 # /etc/webmin/mailboxes 1847 if ($user_module_config_directory && $config{'shortindex'}) { 1848 # Use short name for index file 1849 $f = "$user_module_config_directory/$1.findex"; 1850 } 1851 elsif ($user_module_config_directory) { 1852 # Under user's .usermin directory 1853 $f = "$user_module_config_directory/$us.findex"; 1854 } 1855 else { 1856 # Under /var/webmin or /etc/webmin 1857 $f = "$module_config_directory/$us.findex"; 1858 if (!glob($f."*")) { 1859 $f = "$module_var_directory/$us.findex"; 1860 } 1861 } 1862 } 1863else { 1864 # A username .. the index file is in /var/webmin/modules/mailboxes or 1865 # /etc/webmin/mailboxes 1866 if ($user_module_config_directory) { 1867 $f = "$user_module_config_directory/$_[0].index"; 1868 } 1869 else { 1870 $f = "$module_config_directory/$_[0].index"; 1871 if (!glob($f."*")) { 1872 $f = "$module_var_directory/$_[0].index"; 1873 } 1874 } 1875 } 1876# Append hostname if requested, unless an index file without the hostname 1877# already exists 1878return $config{'noindex_hostname'} ? $f : 1879 -r $f && !-r "$f.$hn" ? $f : "$f.$hn"; 1880} 1881 1882# extract_mail(data) 1883# Converts the text of a message into mail object. 1884sub extract_mail 1885{ 1886local $text = $_[0]; 1887$text =~ s/^\s+//; 1888local ($amail, @aheaders, $i); 1889local @alines = split(/\n/, $text); 1890while($i < @alines && $alines[$i]) { 1891 if ($alines[$i] =~ /^(\S+):\s*(.*)/) { 1892 push(@aheaders, [ $1, $2 ]); 1893 $amail->{'rawheaders'} .= $alines[$i]."\n"; 1894 } 1895 elsif ($alines[$i] =~ /^\s+(.*)/) { 1896 $aheaders[$#aheaders]->[1] .= $1 unless($#aheaders < 0); 1897 $amail->{'rawheaders'} .= $alines[$i]."\n"; 1898 } 1899 $i++; 1900 } 1901$amail->{'headers'} = \@aheaders; 1902foreach $h (@aheaders) { 1903 $amail->{'header'}->{lc($h->[0])} = $h->[1]; 1904 } 1905splice(@alines, 0, $i); 1906$amail->{'body'} = join("\n", @alines)."\n"; 1907return $amail; 1908} 1909 1910# split_addresses(string) 1911# Splits a comma-separated list of addresses into [ email, real-name, original ] 1912# triplets 1913sub split_addresses 1914{ 1915local (@rv, $str = $_[0]); 1916while(1) { 1917 $str =~ s/\\"/\0/g; 1918 if ($str =~ /^[\s,;]*(([^<>\(\)\s"]+)\s+\(([^\(\)]+)\))(.*)$/) { 1919 # An address like foo@bar.com (Fooey Bar) 1920 push(@rv, [ $2, $3, $1 ]); 1921 $str = $4; 1922 } 1923 elsif ($str =~ /^[\s,;]*("([^"]*)"\s*<([^\s<>,]+)>)(.*)$/ || 1924 $str =~ /^[\s,;]*(([^<>\@]+)\s+<([^\s<>,]+)>)(.*)$/ || 1925 $str =~ /^[\s,;]*(([^<>\@]+)<([^\s<>,]+)>)(.*)$/ || 1926 $str =~ /^[\s,;]*(([^<>\[\]]+)\s+\[mailto:([^\s\[\]]+)\])(.*)$/|| 1927 $str =~ /^[\s,;]*(()<([^<>,]+)>)(.*)/ || 1928 $str =~ /^[\s,;]*(()([^\s<>,;]+))(.*)/) { 1929 # Addresses like "Fooey Bar" <foo@bar.com> 1930 # Fooey Bar <foo@bar.com> 1931 # Fooey Bar<foo@bar.com> 1932 # Fooey Bar [mailto:foo@bar.com] 1933 # <foo@bar.com> 1934 # <group name> 1935 # foo@bar.com or foo 1936 my ($all, $name, $email, $rest) = ($1, $2, $3, $4); 1937 $all =~ s/\0/\\"/g; 1938 $name =~ s/\0/"/g; 1939 push(@rv, [ $email, $name eq "," ? "" : $name, $all ]); 1940 $str = $rest; 1941 } 1942 else { 1943 last; 1944 } 1945 } 1946return @rv; 1947} 1948 1949$match_ascii = '\x1b\([BHJ]([\t\x20-\x7e]*)'; 1950$match_jis = '\x1b\$[@B](([\x21-\x7e]{2})*)'; 1951 1952sub eucconv { 1953 local($_) = @_; 1954 if ($current_lang eq 'ja_JP.euc') { 1955 s/$match_jis/&j2e($1)/geo; 1956 s/$match_ascii/$1/go; 1957 } 1958 $_; 1959} 1960 1961sub j2e { 1962 local($_) = @_; 1963 tr/\x21-\x7e/\xa1-\xfe/; 1964 $_; 1965} 1966 1967# eucconv_and_escape(string) 1968# Convert a string for display 1969sub eucconv_and_escape { 1970 return &html_escape(&eucconv($_[0])); 1971} 1972 1973# list_maildir(file, [start], [end], [headersonly]) 1974# Returns a subset of mail from a maildir format directory 1975sub list_maildir 1976{ 1977local (@rv, $i, $f); 1978&mark_read_maildir($_[0]); 1979local @files = &get_maildir_files($_[0]); 1980 1981local ($start, $end); 1982if (!defined($_[1])) { 1983 $start = 0; 1984 $end = @files - 1; 1985 } 1986elsif ($_[2] < 0) { 1987 $start = @files + $_[2] - 1; 1988 $end = @files + $_[1] - 1; 1989 $start = 0 if ($start < 0); 1990 } 1991else { 1992 $start = $_[1]; 1993 $end = $_[2]; 1994 $end = @files-1 if ($end >= @files); 1995 } 1996foreach $f (@files) { 1997 if ($i < $start || $i > $end) { 1998 # Skip files outside requested index range 1999 push(@rv, undef); 2000 $i++; 2001 next; 2002 } 2003 local $mail = &read_mail_file($f, $_[3]); 2004 $mail->{'idx'} = $i++; 2005 $mail->{'id'} = $f; # ID is relative path, like cur/4535534 2006 $mail->{'id'} = substr($mail->{'id'}, length($_[0])+1); 2007 push(@rv, $mail); 2008 } 2009return @rv; 2010} 2011 2012# idlist_maildir(file) 2013# Returns a list of files in a maildir, which form the IDs 2014sub idlist_maildir 2015{ 2016local ($file) = @_; 2017&mark_read_maildir($file); 2018return map { substr($_, length($file)+1) } &get_maildir_files($file); 2019} 2020 2021# select_maildir(file, &ids, headersonly) 2022# Returns a list of messages with the given IDs, from a maildir directory 2023sub select_maildir 2024{ 2025local ($file, $ids, $headersonly) = @_; 2026&mark_read_maildir($file); 2027local @files = &get_maildir_files($file); 2028local @rv; 2029foreach my $i (@$ids) { 2030 local $path = "$file/$i"; 2031 local $mail = &read_mail_file($path, $headersonly); 2032 if (!$mail && $path =~ /^(.*)\/(cur|tmp|new)\/([^:]*)(:2,([A-Za-z]*))?$/) { 2033 # Flag may have changed - update path 2034 local $suffix = "$2/$3"; 2035 local ($newfile) = grep 2036 { substr($_, length($file)+1, length($suffix)) eq $suffix } 2037 @files; 2038 if ($newfile) { 2039 $path = $newfile; 2040 $mail = &read_mail_file($path, $headersonly); 2041 } 2042 } 2043 if (!$mail && $path =~ /\/cur\//) { 2044 # May have moved - update path 2045 $path =~ s/\/cur\//\/new\//g; 2046 $mail = &read_mail_file($path, $headersonly); 2047 } 2048 if ($mail) { 2049 # Set ID from corrected path 2050 $mail->{'id'} = $path; 2051 $mail->{'id'} = substr($mail->{'id'}, length($file)+1); 2052 # Get index in directory 2053 $mail->{'idx'} = &indexof($path, @files); 2054 } 2055 push(@rv, $mail); 2056 } 2057return @rv; 2058} 2059 2060# Get ordered list of message files (with in-memory and on-disk caching, as 2061# this can be slow) 2062# get_maildir_files(directory) 2063sub get_maildir_files 2064{ 2065# Work out last modified time 2066local $newest; 2067foreach my $d ("$_[0]/cur", "$_[0]/new") { 2068 local @dst = stat($d); 2069 $newest = $dst[9] if ($dst[9] > $newest); 2070 } 2071local $skipt = $config{'maildir_deleted'} || $userconfig{'maildir_deleted'}; 2072 2073local @files; 2074if (defined($main::list_maildir_cache{$_[0]}) && 2075 $main::list_maildir_cache_time{$_[0]} == $newest) { 2076 # Use the in-memory cache cache 2077 @files = @{$main::list_maildir_cache{$_[0]}}; 2078 } 2079else { 2080 # Check the on-disk cache file 2081 local $cachefile = &get_maildir_cachefile($_[0]); 2082 local @cst = $cachefile ? stat($cachefile) : ( ); 2083 if ($cst[9] >= $newest) { 2084 # Can read the cache 2085 open(CACHE, "<", $cachefile); 2086 while(<CACHE>) { 2087 chop; 2088 push(@files, $_[0]."/".$_); 2089 } 2090 close(CACHE); 2091 $main::list_maildir_cache_time{$_[0]} = $cst[9]; 2092 } 2093 else { 2094 # Really read 2095 local @shorts; 2096 foreach my $d ("cur", "new") { 2097 &opendir_as_mail_user(DIR, "$_[0]/$d") || &error("Failed to open $_[0]/$d : $!"); 2098 while(my $f = readdir(DIR)) { 2099 next if ($f eq "." || $f eq ".."); 2100 if ($skipt && $f =~ /:2,([A-Za-z]*T[A-Za-z]*)$/) { 2101 # Flagged as deleted by IMAP .. skip 2102 next; 2103 } 2104 push(@shorts, "$d/$f") 2105 } 2106 closedir(DIR); 2107 } 2108 @shorts = sort { substr($a, 4) cmp substr($b, 4) } @shorts; 2109 @files = map { "$_[0]/$_" } @shorts; 2110 2111 # Write out the on-disk cache 2112 if ($cachefile) { 2113 &open_tempfile(CACHE, ">$cachefile", 1); 2114 my $err; 2115 foreach my $f (@shorts) { 2116 my $ok = (print CACHE $f,"\n"); 2117 $err++ if (!$ok); 2118 } 2119 &close_tempfile(CACHE) if (!$err); 2120 local @st = stat($_[0]); 2121 if ($< == 0) { 2122 # Cache should have some ownership as directory 2123 &set_ownership_permissions($st[4], $st[5], 2124 undef, $cachefile); 2125 } 2126 } 2127 $main::list_maildir_cache_time{$_[0]} = $st[9]; 2128 } 2129 $main::list_maildir_cache{$_[0]} = \@files; 2130 } 2131return @files; 2132} 2133 2134# search_maildir(file, field, what) 2135# Search for messages in a maildir directory, and return the results 2136sub search_maildir 2137{ 2138return &advanced_search_maildir($_[0], [ [ $_[1], $_[2] ] ], 1); 2139} 2140 2141# advanced_search_maildir(user|file, &fields, andmode, [&limit], [headersonly]) 2142# Search for messages in a maildir directory, and return the results 2143sub advanced_search_maildir 2144{ 2145&mark_read_maildir($_[0]); 2146local @rv; 2147local ($min, $max); 2148if ($_[3] && $_[3]->{'latest'}) { 2149 $min = -1; 2150 $max = -$_[3]->{'latest'}; 2151 } 2152local $headersonly = $_[4] && !&matches_needs_body($_[1]); 2153foreach $mail (&list_maildir($_[0], $min, $max, $headersonly)) { 2154 push(@rv, $mail) if ($mail && 2155 &mail_matches($_[1], $_[2], $mail)); 2156 } 2157return @rv; 2158} 2159 2160# mark_read_maildir(dir) 2161# Move any messages in the 'new' directory of this maildir to 'cur' 2162sub mark_read_maildir 2163{ 2164local ($dir) = @_; 2165local @files = &get_maildir_files($dir); 2166local $i = 0; 2167foreach my $nf (@files) { 2168 if (substr($nf, length($dir)+1, 3) eq "new") { 2169 local $cf = $nf; 2170 $cf =~ s/\/new\//\/cur\//g; 2171 if (&rename_as_mail_user($nf, $cf)) { 2172 $files[$i] = $cf; 2173 $changed = 1; 2174 } 2175 } 2176 $i++; 2177 } 2178if ($changed) { 2179 # Update the cache 2180 $main::list_maildir_cache{$dir} = \@files; 2181 local $cachefile = &get_maildir_cachefile($dir); 2182 if ($cachefile) { 2183 &open_tempfile(CACHE, ">$cachefile", 1); 2184 foreach my $f (@files) { 2185 local $short = substr($f, length($dir)+1); 2186 &print_tempfile(CACHE, $short,"\n"); 2187 } 2188 &close_tempfile(CACHE); 2189 local @st = stat($_[0]); 2190 if ($< == 0) { 2191 &set_ownership_permissions($st[4], $st[5], 2192 undef, $cachefile); 2193 } 2194 } 2195 } 2196} 2197 2198# delete_maildir(&mail, ...) 2199# Delete messages from a maildir directory 2200sub delete_maildir 2201{ 2202local $m; 2203 2204# Find all maildirs being deleted from 2205local %dirs; 2206foreach $m (@_) { 2207 if ($m->{'file'} =~ /^(.*)\/(cur|new)\/([^\/]+)$/) { 2208 $dirs{$1}->{"$2/$3"} = 1; 2209 } 2210 } 2211 2212# Delete from caches 2213foreach my $dir (keys %dirs) { 2214 local $cachefile = &get_maildir_cachefile($dir); 2215 next if (!$cachefile); 2216 local @cst = stat($cachefile); 2217 next if (!@cst); 2218 2219 # Work out last modified time, and don't update cache if too new 2220 local $newest; 2221 foreach my $d ("$dir/cur", "$dir/new") { 2222 local @dst = stat($d); 2223 $newest = $dst[9] if ($dst[9] > $newest); 2224 } 2225 next if ($newest > $cst[9]); 2226 2227 local $lref = &read_file_lines($cachefile); 2228 for(my $i=0; $i<@$lref; $i++) { 2229 if ($dirs{$dir}->{$lref->[$i]}) { 2230 # Found an entry to remove 2231 splice(@$lref, $i--, 1); 2232 } 2233 } 2234 &flush_file_lines($cachefile); 2235 } 2236 2237# Actually delete the files 2238foreach $m (@_) { 2239 unlink($m->{'file'}); 2240 } 2241 2242} 2243 2244# modify_maildir(&oldmail, &newmail, textonly) 2245# Replaces a message in a maildir directory 2246sub modify_maildir 2247{ 2248unlink($_[0]->{'file'}); 2249&send_mail($_[1], $_[0]->{'file'}, $_[2], 1); 2250} 2251 2252# write_maildir(&mail, directory, textonly) 2253# Adds some message in maildir format to a directory 2254sub write_maildir 2255{ 2256my ($mail, $dir, $textonly) = @_; 2257 2258# Work out last modified time, and don't update cache if too new 2259local $cachefile = &get_maildir_cachefile($dir); 2260local $up2date = 0; 2261if ($cachefile) { 2262 local @cst = stat($cachefile); 2263 if (@cst) { 2264 local $newest; 2265 foreach my $d ("$dir/cur", "$dir/new") { 2266 local @dst = stat($d); 2267 $newest = $dst[9] if ($dst[9] > $newest); 2268 } 2269 $up2date = 1 if ($newest <= $cst[9]); 2270 } 2271 } 2272 2273# Select a unique filename and write to it 2274local $now = time(); 2275$mail->{'id'} = &unique_maildir_filename($dir); 2276$mf = "$dir/$mail->{'id'}"; 2277&send_mail($mail, $mf, $textonly, 1); 2278$mail->{'file'} = $mf; 2279 2280# Set ownership of the new message file to match the directory 2281local @st = stat($dir); 2282if ($< == 0) { 2283 &set_ownership_permissions($st[4], $st[5], undef, $mf); 2284 } 2285 2286# Create tmp and new sub-dirs, if missing 2287foreach my $sd ("tmp", "new") { 2288 local $sdpath = "$dir/$sd"; 2289 if (!-d $sdpath) { 2290 mkdir($sdpath, 0755); 2291 if ($< == 0) { 2292 &set_ownership_permissions($st[4], $st[5], 2293 undef, $sdpath); 2294 } 2295 } 2296 } 2297 2298if ($up2date && $cachefile) { 2299 # Bring cache up to date 2300 $now--; 2301 local $lref = &read_file_lines($cachefile); 2302 push(@$lref, $mail->{'id'}); 2303 &flush_file_lines($cachefile); 2304 } 2305} 2306 2307# unique_maildir_filename(dir) 2308# Returns a filename for a new message in a maildir, relative to the directory 2309sub unique_maildir_filename 2310{ 2311local ($dir) = @_; 2312mkdir("$dir/cur", 0755); 2313local $now = time(); 2314local $hn = &get_system_hostname(); 2315++$main::write_maildir_count; 2316local $rv; 2317do { 2318 $rv = "cur/$now.$$.$main::write_maildir_count.$hn"; 2319 $now++; 2320 } while(-r "$dir/$rv"); 2321return $rv; 2322} 2323 2324# empty_maildir(file) 2325# Delete all messages in an maildir directory 2326sub empty_maildir 2327{ 2328local $d; 2329foreach $d ("$_[0]/cur", "$_[0]/new") { 2330 local $f; 2331 &opendir_as_mail_user(DIR, $d) || &error("Failed to open $d : $!"); 2332 while($f = readdir(DIR)) { 2333 unlink("$d/$f") if ($f ne '.' && $f ne '..'); 2334 } 2335 closedir(DIR); 2336 } 2337&flush_maildir_cachefile($_[0]); 2338} 2339 2340# get_maildir_cachefile(dir) 2341# Returns the cache file for a maildir directory 2342sub get_maildir_cachefile 2343{ 2344local ($dir) = @_; 2345local $cd; 2346if ($user_module_config_directory) { 2347 $cd = $user_module_config_directory; 2348 } 2349else { 2350 $cd = $module_config_directory; 2351 if (!-r "$cd/maildircache") { 2352 $cd = $module_var_directory; 2353 } 2354 } 2355local $sd = "$cd/maildircache"; 2356if (!-d $sd) { 2357 &make_dir($sd, 0755) || return undef; 2358 } 2359$dir =~ s/\//_/g; 2360return "$sd/$dir"; 2361} 2362 2363# flush_maildir_cachefile(dir) 2364# Clear the on-disk and in-memory maildir caches 2365sub flush_maildir_cachefile 2366{ 2367local ($dir) = @_; 2368local $cachefile = &get_maildir_cachefile($dir); 2369unlink($cachefile) if ($cachefile); 2370delete($main::list_maildir_cache{$dir}); 2371delete($main::list_maildir_cache_time{$dir}); 2372} 2373 2374# count_maildir(dir) 2375# Returns the number of messages in a maildir directory 2376sub count_maildir 2377{ 2378local @files = &get_maildir_files($_[0]); 2379return scalar(@files); 2380} 2381 2382# list_mhdir(file, [start], [end], [headersonly]) 2383# Returns a subset of mail from an MH format directory 2384sub list_mhdir 2385{ 2386local ($start, $end, $f, $i, @rv); 2387&opendir_as_mail_user(DIR, $_[0]) || &error("Failed to open $_[0] : $!"); 2388local @files = map { "$_[0]/$_" } 2389 sort { $a <=> $b } 2390 grep { /^\d+$/ } readdir(DIR); 2391closedir(DIR); 2392if (!defined($_[1])) { 2393 $start = 0; 2394 $end = @files - 1; 2395 } 2396elsif ($_[2] < 0) { 2397 $start = @files + $_[2] - 1; 2398 $end = @files + $_[1] - 1; 2399 $start = 0 if ($start < 0); 2400 } 2401else { 2402 $start = $_[1]; 2403 $end = $_[2]; 2404 $end = @files-1 if ($end >= @files); 2405 } 2406foreach $f (@files) { 2407 if ($i < $start || $i > $end) { 2408 # Skip files outside requested index range 2409 push(@rv, undef); 2410 $i++; 2411 next; 2412 } 2413 local $mail = &read_mail_file($f, $_[3]); 2414 $mail->{'idx'} = $i++; 2415 $mail->{'id'} = $f; # ID is message number 2416 $mail->{'id'} = substr($mail->{'id'}, length($_[0])+1); 2417 push(@rv, $mail); 2418 } 2419return @rv; 2420} 2421 2422# idlist_mhdir(directory) 2423# Returns a list of files in an MH directory, which are the IDs 2424sub idlist_mhdir 2425{ 2426local ($dir) = @_; 2427&opendir_as_mail_user(DIR, $dir) || &error("Failed to open $dir : $!"); 2428local @files = grep { /^\d+$/ } readdir(DIR); 2429closedir(DIR); 2430return @files; 2431} 2432 2433# get_mhdir_files(directory) 2434# Returns a list of full paths to files in an MH directory 2435sub get_mhdir_files 2436{ 2437local ($dir) = @_; 2438return map { "$dir/$_" } &idlist_mhdir($dir); 2439} 2440 2441# select_mhdir(file, &ids, headersonly) 2442# Returns a list of messages with the given indexes, from an mhdir directory 2443sub select_mhdir 2444{ 2445local ($file, $ids, $headersonly) = @_; 2446local @rv; 2447&opendir_as_mail_user(DIR, $file) || &error("Failed to open $file : $!"); 2448local @files = map { "$file/$_" } 2449 sort { $a <=> $b } 2450 grep { /^\d+$/ } readdir(DIR); 2451closedir(DIR); 2452foreach my $i (@$ids) { 2453 local $mail = &read_mail_file("$file/$i", $headersonly); 2454 if ($mail) { 2455 $mail->{'idx'} = &indexof("$file/$i", @files); 2456 $mail->{'id'} = $i; 2457 } 2458 push(@rv, $mail); 2459 } 2460return @rv; 2461} 2462 2463# search_mhdir(file|user, field, what) 2464# Search for messages in an MH directory, and return the results 2465sub search_mhdir 2466{ 2467return &advanced_search_mhdir($_[0], [ [ $_[1], $_[2] ] ], 1); 2468} 2469 2470# advanced_search_mhdir(file|user, &fields, andmode, &limit, [headersonly]) 2471# Search for messages in an MH directory, and return the results 2472sub advanced_search_mhdir 2473{ 2474local @rv; 2475local ($min, $max); 2476if ($_[3] && $_[3]->{'latest'}) { 2477 $min = -1; 2478 $max = -$_[3]->{'latest'}; 2479 } 2480local $headersonly = $_[4] && !&matches_needs_body($_[1]); 2481foreach $mail (&list_mhdir($_[0], $min, $max, $headersonly)) { 2482 push(@rv, $mail) if ($mail && &mail_matches($_[1], $_[2], $mail)); 2483 } 2484return @rv; 2485} 2486 2487# delete_mhdir(&mail, ...) 2488# Delete messages from an MH directory 2489sub delete_mhdir 2490{ 2491local $m; 2492foreach $m (@_) { 2493 unlink($m->{'file'}); 2494 } 2495} 2496 2497# modify_mhdir(&oldmail, &newmail, textonly) 2498# Replaces a message in a maildir directory 2499sub modify_mhdir 2500{ 2501unlink($_[0]->{'file'}); 2502&send_mail($_[1], $_[0]->{'file'}, $_[2], 1); 2503} 2504 2505# max_mhdir(dir) 2506# Returns the maximum message ID in the directory 2507sub max_mhdir 2508{ 2509local $max = 1; 2510&opendir_as_mail_user(DIR, $_[0]) || &error("Failed to open $_[0] : $!"); 2511foreach my $f (readdir(DIR)) { 2512 $max = $f if ($f =~ /^\d+$/ && $f > $max); 2513 } 2514closedir(DIR); 2515return $max; 2516} 2517 2518# empty_mhdir(file) 2519# Delete all messages in an MH format directory 2520sub empty_mhdir 2521{ 2522&opendir_as_mail_user(DIR, $_[0]) || &error("Failed to open $_[0] : $!"); 2523foreach my $f (readdir(DIR)) { 2524 unlink("$_[0]/$f") if ($f =~ /^\d+$/); 2525 } 2526closedir(DIR); 2527} 2528 2529# count_mhdir(file) 2530# Returns the number of messages in an MH directory 2531sub count_mhdir 2532{ 2533&opendir_as_mail_user(DIR, $_[0]) || &error("Failed to open $_[0] : $!"); 2534local @files = grep { /^\d+$/ } readdir(DIR); 2535closedir(DIR); 2536return scalar(@files); 2537} 2538 2539# list_mbxfile(file, start, end) 2540# Return messages from an MBX format file 2541sub list_mbxfile 2542{ 2543local @rv; 2544&open_as_mail_user(MBX, $_[0]) || &error("Failed to open $_[0] : $!"); 2545seek(MBX, 2048, 0); 2546while(my $line = <MBX>) { 2547 if ($line =~ m/( \d|\d\d)-(\w\w\w)-(\d\d\d\d) (\d\d):(\d\d):(\d\d) ([+-])(\d\d)(\d\d),(\d+);([[:xdigit:]]{8})([[:xdigit:]]{4})-([[:xdigit:]]{8})\r\n$/) { 2548 my $size = $10; 2549 my $mail = &read_mail_fh(MBX, $size, 0); 2550 push(@rv, $mail); 2551 } 2552 } 2553close(MBX); 2554return @rv; 2555} 2556 2557# select_mbxfile(file, &ids, headersonly) 2558# Returns a list of messages with the given indexes, from a MBX file 2559sub select_mbxfile 2560{ 2561local ($file, $ids, $headersonly) = @_; 2562local @all = &list_mbxfile($file); 2563local @rv; 2564foreach my $i (@$ids) { 2565 push(@rv, $all[$i]); 2566 } 2567return @rv; 2568} 2569 2570# read_mail_file(file, [headersonly]) 2571# Read a single message from a file 2572sub read_mail_file 2573{ 2574local (@headers, $mail); 2575 2576# Open and read the mail file 2577&open_as_mail_user(MAIL, $_[0]) || return undef; 2578$mail = &read_mail_fh(MAIL, 0, $_[1]); 2579$mail->{'file'} = $_[0]; 2580close(MAIL); 2581local @st = stat($_[0]); 2582$mail->{'size'} = $st[7]; 2583$mail->{'time'} = $st[9]; 2584 2585# Set read flags based on the name 2586if ($_[0] =~ /:2,([A-Za-z]*)$/) { 2587 local @flags = split(//, $1); 2588 $mail->{'read'} = &indexoflc("S", @flags) >= 0 ? 1 : 0; 2589 $mail->{'special'} = &indexoflc("F", @flags) >= 0 ? 1 : 0; 2590 $mail->{'replied'} = &indexoflc("R", @flags) >= 0 ? 1 : 0; 2591 $mail->{'flags'} = 1; 2592 } 2593 2594return $mail; 2595} 2596 2597# read_mail_fh(handle, [end-mode], [headersonly]) 2598# Reads an email message from the given file handle, either up to end of 2599# the file, or a From line. End mode 0 = EOF, 1 = From without -, 2600# 2 = From possibly with -, 2601# higher = number of bytes 2602sub read_mail_fh 2603{ 2604local ($fh, $endmode, $headeronly) = @_; 2605local (@headers, $mail); 2606 2607# Read the headers 2608local $lnum = 0; 2609while(1) { 2610 $lnum++; 2611 local $line = <$fh>; 2612 $mail->{'size'} += length($line); 2613 $line =~ s/\r|\n//g; 2614 last if ($line eq ''); 2615 if ($line =~ /^(\S+):\s*(.*)/) { 2616 push(@headers, [ $1, $2 ]); 2617 $mail->{'rawheaders'} .= $line."\n"; 2618 } 2619 elsif ($line =~ /^\s+(.*)/) { 2620 $headers[$#headers]->[1] .= " ".$1 unless($#headers < 0); 2621 $mail->{'rawheaders'} .= $line."\n"; 2622 } 2623 elsif ($line =~ /^From\s+(\S+).*\d+/ && 2624 ($1 ne '-' || $endmode == 2)) { 2625 $mail->{'fromline'} = $line; 2626 } 2627 } 2628$mail->{'headers'} = \@headers; 2629foreach $h (@headers) { 2630 $mail->{'header'}->{lc($h->[0])} = $h->[1]; 2631 } 2632 2633if (!$headersonly) { 2634 # Read the mail body 2635 if ($endmode == 0) { 2636 # Till EOF 2637 my $bs = &get_buffer_size(); 2638 while(read($fh, $buf, $bs) > 0) { 2639 $mail->{'size'} += length($buf); 2640 $mail->{'body'} .= $buf; 2641 $lc = ($buf =~ tr/\n/\n/); 2642 $lnum += $lc; 2643 } 2644 close(MAIL); 2645 } 2646 elsif ($endmode > 2) { 2647 # Till we have enough bytes 2648 while($mail->{'size'} < $endmode) { 2649 $line = <$fh>; 2650 $lnum++; 2651 $mail->{'size'} += length($line); 2652 $mail->{'body'} .= $line; 2653 } 2654 } 2655 else { 2656 # Till next From line 2657 while(1) { 2658 $line = <$fh>; 2659 last if (!$line || $line =~ /^From\s+(\S+).*\d+\r?\n/ && 2660 ($1 ne '-' || $endmode == 2)); 2661 $lnum++; 2662 $mail->{'size'} += length($line); 2663 $mail->{'body'} .= $line; 2664 } 2665 } 2666 $mail->{'lines'} = $lnum; 2667 } 2668elsif ($endmode) { 2669 # Not reading the body, but we still need to search till the next 2670 # From: line in order to get the size 2671 while(1) { 2672 $line = <$fh>; 2673 last if (!$line || $line =~ /^From\s+(\S+).*\d+\r?\n/ && 2674 ($1 ne '-' || $endmode == 2)); 2675 $lnum++; 2676 $mail->{'size'} += length($line); 2677 } 2678 $mail->{'lines'} = $lnum; 2679 } 2680return $mail; 2681} 2682 2683# dash_mode(user|file) 2684# Returns 1 if the messages in this folder are separated by lines like 2685# From - instead of the usual From foo@bar.com 2686sub dash_mode 2687{ 2688&open_as_mail_user(DASH, &user_mail_file($_[0])) || return 0; # assume no 2689local $line = <DASH>; 2690close(DASH); 2691return $line =~ /^From\s+(\S+).*\d/ && $1 eq '-'; 2692} 2693 2694# mail_matches(&fields, andmode, &mail) 2695# Returns 1 if some message matches a search 2696sub mail_matches 2697{ 2698local $count = 0; 2699local $f; 2700foreach $f (@{$_[0]}) { 2701 local $field = $f->[0]; 2702 local $what = $f->[1]; 2703 local $neg = ($field =~ s/^\!//); 2704 local $re = $f->[2] ? $what : "\Q$what\E"; 2705 if ($field eq 'body') { 2706 $count++ 2707 if (!$neg && $_[2]->{'body'} =~ /$re/i || 2708 $neg && $_[2]->{'body'} !~ /$re/i); 2709 } 2710 elsif ($field eq 'size') { 2711 $count++ 2712 if (!$neg && $_[2]->{'size'} > $what || 2713 $neg && $_[2]->{'size'} < $what); 2714 } 2715 elsif ($field eq 'headers') { 2716 local $headers = $_[2]->{'rawheaders'} || 2717 join("", map { $_->[0].": ".$_->[1]."\n" } 2718 @{$_[2]->{'headers'}}); 2719 $count++ 2720 if (!$neg && $headers =~ /$re/i || 2721 $neg && $headers !~ /$re/i); 2722 } 2723 elsif ($field eq 'all') { 2724 local $headers = $_[2]->{'rawheaders'} || 2725 join("", map { $_->[0].": ".$_->[1]."\n" } 2726 @{$_[2]->{'headers'}}); 2727 $count++ 2728 if (!$neg && ($_[2]->{'body'} =~ /$re/i || 2729 $headers =~ /$re/i) || 2730 $neg && ($_[2]->{'body'} !~ /$re/i && 2731 $headers !~ /$re/i)); 2732 } 2733 elsif ($field eq 'status') { 2734 $count++ 2735 if (!$neg && $_[2]->{$field} =~ /$re/i|| 2736 $neg && $_[2]->{$field} !~ /$re/i); 2737 } 2738 else { 2739 $count++ 2740 if (!$neg && $_[2]->{'header'}->{$field} =~ /$re/i|| 2741 $neg && $_[2]->{'header'}->{$field} !~ /$re/i); 2742 } 2743 return 1 if ($count && !$_[1]); 2744 } 2745return $count == scalar(@{$_[0]}); 2746} 2747 2748# search_fields(&fields) 2749# Returns an array of headers/fields from a search 2750sub search_fields 2751{ 2752local @rv; 2753foreach my $f (@{$_[0]}) { 2754 $f->[0] =~ /^\!?(.*)$/; 2755 push(@rv, $1); 2756 } 2757return &unique(@rv); 2758} 2759 2760# matches_needs_body(&fields) 2761# Returns 1 if a search needs to check the mail body 2762sub matches_needs_body 2763{ 2764foreach my $f (@{$_[0]}) { 2765 return 1 if ($f->[0] eq 'body' || $f->[0] eq 'all'); 2766 } 2767return 0; 2768} 2769 2770# parse_delivery_status(text) 2771# Returns the fields from a message/delivery-status attachment 2772sub parse_delivery_status 2773{ 2774local @lines = split(/[\r\n]+/, $_[0]); 2775local (%rv, $l); 2776foreach $l (@lines) { 2777 if ($l =~ /^(\S+):\s*(.*)/) { 2778 $rv{lc($1)} = $2; 2779 } 2780 } 2781return \%rv; 2782} 2783 2784# parse_mail_date(string) 2785# Converts a mail Date: header into a unix time 2786sub parse_mail_date 2787{ 2788local ($str) = @_; 2789$str =~ s/^[, \t]+//; 2790$str =~ s/\s+$//; 2791open(OLDSTDERR, ">&STDERR"); # suppress STDERR from Time::Local 2792close(STDERR); 2793my $rv = eval { 2794 if ($str =~ /^(\S+),\s+(\d+)\s+(\S+)\s+(\d+)\s+(\d+):\s?(\d+):\s?(\d+)\s+(\S+)/) { 2795 # Format like Mon, 13 Dec 2004 14:40:41 +0100 2796 # or Mon, 13 Dec 2004 14:18:16 GMT 2797 # or Tue, 14 Sep 04 02:45:09 GMT 2798 local $tm = timegm($7, $6, $5, $2, &month_to_number($3), 2799 $4 < 50 ? $4+100 : $4 < 1000 ? $4 : $4-1900); 2800 local $tz = $8; 2801 if ($tz =~ /^(\-|\+)?\d+$/) { 2802 local $tz = int($tz); 2803 $tz = $tz/100 if ($tz >= 50 || $tz <= -50); 2804 $tm -= $tz*60*60; 2805 } 2806 return $tm; 2807 } 2808 elsif ($str =~ /^(\S+),\s+(\d+),?\s+(\S+)\s+(\d+)\s+(\d+):\s?(\d+):\s?(\d+)/) { 2809 # Format like Mon, 13 Dec 2004 14:40:41 or 2810 # Mon, 13, Dec 2004 14:40:41 2811 # No timezone, so assume local 2812 local $tm = timelocal($7, $6, $5, $2, &month_to_number($3), 2813 $4 < 50 ? $4+100 : $4 < 1000 ? $4 : $4-1900); 2814 return $tm; 2815 } 2816 elsif ($str =~ /^(\S+)\s+(\S+)\s+(\d+)\s+(\d+):(\d+):(\d+)\s+(\d+)/) { 2817 # Format like Tue Dec 7 12:58:52 2004 2818 local $tm = timelocal($6, $5, $4, $3, &month_to_number($2), 2819 $7 < 50 ? $7+100 : $7 < 1000 ? $7 : $7-1900); 2820 return $tm; 2821 } 2822 elsif ($str =~ /^(\S+)\s+(\S+)\s+(\d{1,2})\s+(\d+):(\d+):(\d+)/ && 2823 &month_to_number($2)) { 2824 # Format like Tue Dec 7 12:58:52 2825 local @now = localtime(time()); 2826 local $tm = timelocal($6, $5, $4, $3, &month_to_number($2), 2827 $now[5]); 2828 return $tm; 2829 } 2830 elsif ($str =~ /^(\S+)\s+(\S+)\s+(\d{1,2})\s+(\d+):(\d+)$/ && 2831 defined(&month_to_number($2))) { 2832 # Format like Tue Dec 7 12:58 2833 local @now = localtime(time()); 2834 local $tm = timelocal(0, $5, $4, $3, &month_to_number($2), 2835 $now[5]); 2836 return $tm; 2837 } 2838 elsif ($str =~ /^(\S+)\s+(\d{1,2})\s+(\d+):(\d+)$/ && 2839 defined(&month_to_number($1))) { 2840 # Format like Dec 7 12:58 2841 local @now = localtime(time()); 2842 local $tm = timelocal(0, $4, $3, $2, &month_to_number($1), 2843 $now[5]); 2844 return $tm; 2845 } 2846 elsif ($str =~ /^(\S+)\s+(\d+)\s+(\d+):(\d+):(\d+)\s+(\d+)\s+(\S+)/) { 2847 # Format like Dec 7 12:58:52 2004 GMT 2848 local $tm = timegm($5, $4, $3, $2, &month_to_number($1), 2849 $6 < 50 ? $6+100 : $6 < 1000 ? $6 : $6-1900); 2850 local $tz = $7; 2851 if ($tz =~ /^(\-|\+)?\d+$/) { 2852 $tz = int($tz); 2853 $tz = $tz/100 if ($tz >= 50 || $tz <= -50); 2854 $tm -= $tz*60*60; 2855 } 2856 return $tm; 2857 } 2858 elsif ($str =~ /^(\d{4})\-(\d+)\-(\d+)\s+(\d+):(\d+)/) { 2859 # Format like 2004-12-07 12:53 2860 local $tm = timelocal(0, $4, $4, $3, $2-1, 2861 $1 < 50 ? $1+100 : $1 < 1000 ? $1 : $1-1900); 2862 return $tm; 2863 } 2864 elsif ($str =~ /^(\d+)\s+(\S+)\s+(\d+)\s+(\d+):(\d+):(\d+)\s+(\S+)/) { 2865 # Format like 30 Jun 2005 21:01:01 -0000 2866 local $tm = timegm($6, $5, $4, $1, &month_to_number($2), 2867 $3 < 50 ? $3+100 : $3 < 1000 ? $3 : $3-1900); 2868 local $tz = $7; 2869 if ($tz =~ /^(\-|\+)?\d+$/) { 2870 $tz = int($tz); 2871 $tz = $tz/100 if ($tz >= 50 || $tz <= -50); 2872 $tm -= $tz*60*60; 2873 } 2874 return $tm; 2875 } 2876 elsif ($str =~ /^(\d+)\/(\S+)\/(\d+)\s+(\d+):(\d+)/) { 2877 # Format like 21/Feb/2008 24:13 2878 local $tm = timelocal(0, $5, $4, $1, &month_to_number($2), 2879 $3-1900); 2880 return $tm; 2881 } 2882 else { 2883 return undef; 2884 } 2885 }; 2886open(STDERR, ">&OLDSTDERR"); 2887close(OLDSTDERR); 2888if ($@) { 2889 #print STDERR "parsing of $str failed : $@\n"; 2890 return undef; 2891 } 2892return $rv; 2893} 2894 2895# send_text_mail(from, to, cc, subject, body, [smtp-server]) 2896# A convenience function for sending a email with just a text body 2897sub send_text_mail 2898{ 2899local ($from, $to, $cc, $subject, $body, $smtp) = @_; 2900local $cs = &get_charset(); 2901local $attach = 2902 { 'headers' => [ [ 'Content-Type', 'text/plain; charset='.$cs ], 2903 [ 'Content-Transfer-Encoding', 'quoted-printable' ] ], 2904 'data' => "ed_encode($body) }; 2905local $mail = { 'headers' => 2906 [ [ 'From', $from ], 2907 [ 'To', $to ], 2908 [ 'Cc', $cc ], 2909 [ 'Subject', &encode_mimewords($subject) ] ], 2910 'attach' => [ $attach ] }; 2911return &send_mail($mail, undef, 1, 0, $smtp); 2912} 2913 2914# make_from_line(address, [time]) 2915# Returns a From line for mbox emails, based on the current time 2916sub make_from_line 2917{ 2918local ($addr, $t) = @_; 2919$t ||= time(); 2920&clear_time_locale(); 2921local $rv = "From $addr ".strftime("%a %b %e %H:%M:%S %Y", localtime($t)); 2922&reset_time_locale(); 2923return $rv; 2924} 2925 2926sub notes_decode 2927{ 2928# Deprecated - does nothing 2929} 2930 2931# add_mailer_ip_headers(&headers) 2932# Add X-Mailer and X-Originating-IP headers, if enabled 2933sub add_mailer_ip_headers 2934{ 2935local ($headers) = @_; 2936if (!$config{'no_orig_ip'}) { 2937 push(@$headers, [ 'X-Originating-IP', $ENV{'REMOTE_ADDR'} ]); 2938 } 2939if (!$config{'no_mailer'}) { 2940 push(@$headers, [ 'X-Mailer', ucfirst(&get_product_name())." ". 2941 &get_webmin_version() ]); 2942 } 2943} 2944 2945# set_mail_open_user(user) 2946# Sets the Unix user that will be used for all mail file open ops, by functions 2947# like list_mail and select_maildir 2948sub set_mail_open_user 2949{ 2950my ($user) = @_; 2951if ($user eq "root" || $user eq "0") { 2952 $main::mail_open_user = undef; 2953 } 2954elsif (!$<) { 2955 $main::mail_open_user = $user; 2956 } 2957} 2958 2959# clear_mail_open_user() 2960# Resets the user to root 2961sub clear_mail_open_user 2962{ 2963my ($user) = @_; 2964$main::mail_open_user = undef; 2965} 2966 2967# open_as_mail_user(fh, file) 2968# Calls the open function, but as the user set by set_mail_open_user 2969sub open_as_mail_user 2970{ 2971my ($fh, $file) = @_; 2972my $switched = &switch_to_mail_user(); 2973my $mode = "<"; 2974if ($file =~ s/^(<|>>|>|\|)//) { 2975 $mode = $1; 2976 } 2977my $rv = open($fh, $mode, $file); 2978if ($switched) { 2979 # Now that it is open, switch back to root 2980 $) = 0; 2981 $> = 0; 2982 } 2983return $rv; 2984} 2985 2986# create_as_mail_user(fh, file) 2987# Creates a new file, but ensures that it does not yet exist first, and then 2988# sets the ownership to the mail user 2989sub create_as_mail_user 2990{ 2991my ($fh, $file) = @_; 2992if (&should_switch_to_mail_user()) { 2993 # Open the file as root, but ensure that it doesn't exist yet. Then 2994 # make it owned by the user 2995 $file =~ s/^>+//; 2996 my $rv = sysopen($fh, $file, O_CREAT|O_WRONLY, 0700); 2997 return $rv if (!$rv); 2998 my @uinfo = &get_switch_user_info(); 2999 &set_ownership_permissions($uinfo[2], $uinfo[3], undef, $file); 3000 return $rv; 3001 } 3002else { 3003 # Operating as root, so no special behaviour needed 3004 if ($file =~ /^(<|>)/) { 3005 return open($fh, $file); 3006 } 3007 else { 3008 return open($fh, "<", $file); 3009 } 3010 } 3011} 3012 3013# opendir_as_mail_user(fh, dir) 3014# Calls the opendir function, but as the user set by set_mail_open_user 3015sub opendir_as_mail_user 3016{ 3017my ($fh, $dir) = @_; 3018my $switched = &switch_to_mail_user(); 3019my $rv = opendir($fh, $dir); 3020if ($switched) { 3021 $) = 0; 3022 $> = 0; 3023 } 3024return $rv; 3025} 3026 3027# rename_as_mail_user(old, new) 3028# Like the rename function, but as the user set by set_mail_open_user 3029sub rename_as_mail_user 3030{ 3031my ($oldfile, $newfile) = @_; 3032my $switched = &switch_to_mail_user(); 3033my $rv = &rename_file($oldfile, $newfile); 3034if ($switched) { 3035 $) = 0; 3036 $> = 0; 3037 } 3038return $rv; 3039} 3040 3041# mkdir_as_mail_user(path, perms) 3042# Like the mkdir function, but as the user set by set_mail_open_user 3043sub mkdir_as_mail_user 3044{ 3045my ($path, $perms) = @_; 3046my $switched = &switch_to_mail_user(); 3047my $rv = mkdir($path, $perms); 3048if ($switched) { 3049 $) = 0; 3050 $> = 0; 3051 } 3052return $rv; 3053} 3054 3055# unlink_as_mail_user(path) 3056# Like the unlink function, but as the user set by set_mail_open_user 3057sub unlink_as_mail_user 3058{ 3059my ($path) = @_; 3060my $switched = &switch_to_mail_user(); 3061my $rv = unlink($path); 3062if ($switched) { 3063 $) = 0; 3064 $> = 0; 3065 } 3066return $rv; 3067} 3068 3069# copy_source_dest_as_mail_user(source, dest) 3070# Copy a file, with perms of the user from set_mail_open_user 3071sub copy_source_dest_as_mail_user 3072{ 3073my ($src, $dst) = @_; 3074if (&should_switch_to_mail_user()) { 3075 &open_as_mail_user(SRC, $src) || return 0; 3076 &open_as_mail_user(DST, ">$dst") || return 0; 3077 my $buf; 3078 my $bs = &get_buffer_size(); 3079 while(read(SRC, $buf, $bs) > 0) { 3080 print DST $buf; 3081 } 3082 close(SRC); 3083 close(DST); 3084 return 1; 3085 } 3086else { 3087 return ©_source_dest($src, $dst); 3088 } 3089} 3090 3091# chmod_as_mail_user(perms, file, ...) 3092# Set file permissions, but with perms of the user from set_mail_open_user 3093sub chmod_as_mail_user 3094{ 3095my ($perms, @files) = @_; 3096my $switched = &switch_to_mail_user(); 3097my $rv = chmod($perms, @files); 3098if ($switched) { 3099 $) = 0; 3100 $> = 0; 3101 } 3102return $rv; 3103} 3104 3105# should_switch_to_mail_user() 3106# Returns 1 if file IO will be done as a mail owner user 3107sub should_switch_to_mail_user 3108{ 3109return defined($main::mail_open_user) && !$< && !$>; 3110} 3111 3112# switch_to_mail_user() 3113# Sets the permissions used for reading files 3114sub switch_to_mail_user 3115{ 3116if (&should_switch_to_mail_user()) { 3117 # Switch file permissions to the correct user 3118 my @uinfo = &get_switch_user_info(); 3119 @uinfo || &error("Mail open user $main::mail_open_user ". 3120 "does not exist"); 3121 $) = $uinfo[3]." ".join(" ", $uinfo[3], &other_groups($uinfo[0])); 3122 $> = $uinfo[2]; 3123 return 1; 3124 } 3125return 0; 3126} 3127 3128# get_switch_user_info() 3129# Returns the getpw* function array for the user to switch to 3130sub get_switch_user_info 3131{ 3132if ($main::mail_open_user =~ /^\d+$/) { 3133 # Could be by UID .. but fall back to by name if there is no such UID 3134 my @rv = getpwuid($main::mail_open_user); 3135 return @rv if (@rv > 0); 3136 } 3137return getpwnam($main::mail_open_user); 3138} 3139 3140# is_ascii() 3141# Checks if string is ASCII 3142sub is_ascii { 3143my ($str) = @_; 3144my $str_ = $str; 3145utf8::encode($str_); 3146if ($str eq $str_) { 3147 return 1; 3148 } 3149else { 3150 return 0; 3151 } 3152} 3153 31541; 3155