Listing 1. Perl Filter for LMAILER
#!/usr/bin/perl
################################################################
# Check rules to send email to controlled lists and
# replace attached files with url to the corresponding file
# Ricardo Ciria. March 2002
################################################################
use strict ;
#
# ... global variables
#
my ($s_machine, %ext_known, %ext_supposed, %ext_supposed2,
$dest_user, $TempBody, $xtended, $description,
$MailBody, $the_file, $TempBodyNew, $the_file_out,
$cmd, $out_cmd, $send, $pid, $kind, $recip,
$s_user, $sender, $ext, %ext) ;
#
#-------------------- configurable section starts ----------
#
# ... configurable variables
#
#------------------------------------------------------------
# ... system configurable variables
my $mkdir = "/bin/mkdir" ;
my $munpack = "/usr/bin/munpack" ;
my $file = "/usr/bin/file" ;
my $grep = "/bin/grep" ;
my $sendmail = "/usr/sbin/sendmail" ;
# ... directories and files
my $dir_attach = "/home/ATTACH"; # attachments will be stored here
my $log_file = "/home/ROOT/la_chacha_log" ;
# ... allowed domains
my %allowed = ("ibt.unam.mx" => 1, "ceingebi.unam.mx" => 1);
# ... web server and directory
my $http = "http://www.ibt.unam.mx/ata" ;
# ... general rejecting message
my $msg = "\n You can NOT sent to this list\n\n" ;
#
# ... controlled lists checking
#
sub controlled {
# ... check for mailing rights.
# a conditional statement MUST be added here
# for each controlled list
if ($dest_user eq "everybody"){ &check_everybody() ;
}elsif ($dest_user eq "leader") { &check_leader() ;
}#if
}#sub
#
# ... local list subroutines(s)
#
#-------------------------------------------------------------
sub check_everybody {
my ($the_user, $a) ;
# ... the sender must be in "test_list"
my $test_list = "/etc/mail/aliases.d/everybody" ;
if ($allowed{$s_machine}) { # ... if domain is allowed
# ... grep the user in the test list
$the_user = "\'^$s_user\'" ;
open(LS,"$grep $the_user $test_list |") ;
$a = ; chop($a) ; close (LS) ;
if ($a eq $s_user) {
$send = 1 ; # ... ok, send it
# ... the real recipient (the back slash is needed)
$recip = "ydobyreve\@ibt.unam.mx" ;
$msg = "(Message send to )\n\n";
}#if
}#if
}#sub
sub check_leader {
my $leader_acount = "bigboss" ;
$msg = "Are you trying to pretend be me?\n" ;
if ($allowed{$s_machine}) {
if ($leader_acount eq $s_user) {
$send = 1 ;
$recip = "redael\@ibt.unam.mx" ;
$msg = "Message from LEADER. Read carefully.\n\n";
}#if
}#if
}#sub
#
#-------------------- configurable section ends --------------
#
$pid = $$ ;
my $temp_dir = "/tmp/ata-$pid" ;
$send = 0 ; # ... sending flag. Zero = rejected.
open_files() ; # ... temporal files
load_extensions() ;
LINE: # ... get header. store it in MBODY
while(<>){
next LINE if $_ =~ /^From / ;
next LINE if $_ =~ /^Received:/ ;
next LINE if $_ =~ /^Content-Type:/ ;
next LINE if $_ =~ /^Content-ID:/ ;
next LINE if( index($_,"\t")==0 );
&get_sender() if (/^From:/) ;
&get_dest() if (/^To:/) ;
last if(length($_) < 2) ; #... header ends
print MBODY $_ ;
}#while
controlled() ; # ... mailing rights check call.
#&update_log() ; # ... comment this line if log is not needed
print MBODY $msg ; # ... copy comments to message
unless ($send) { # ... rejected
close TMP ; unlink $TempBody ; # ... remove TMP
close TMPNVO ; unlink $TempBodyNew ; # ... and TMPNVO
send_mail() ;
exit ;
}#if
# ... copy original e-mail body to file TMP
print TMP $_ while (<>) ; close(TMP);
# ... replace NAME* by NAME and FILENAME* by FILENAME
open(TMP,"$TempBody") || die "$TempBody: $!";
while ($a =) {
$a =~ s/NAME\*\=/NAME\=/g if ($a =~ /^Content\-Type/) ;
$a =~ s/NAME\*\=/NAME\=/g if ($a =~ /^Content\-Disposition/) ;
print TMPNVO $a ;
}#while... now, the email body is in TMPNVO
close TMP ; unlink $TempBody ; # ... remove TMP
close TMPNVO ;
# ... unpacks (if any) the messages. The output is stored in
# $TempBody.aux and the unpacked files in $temp_dir.
system "$mkdir $temp_dir" ;
system "$munpack -C $temp_dir -t $TempBodyNew > $TempBody.aux" ;
open(PACK,"$TempBody.aux") ;
while ($a=) { #... check munpack output
if ($a =~ /$TempBodyNew/) { # ... Did not find anything to unpack
# ... no parts¨: move TMPNVO contents to MBODY
open(TMPNVO,"$TempBodyNew") || die "$TempBodyNew: $!";
print MBODY $a while ($a=) ;
close TMPNVO ;
last ;
}else{ # ... the message have "parts"
($the_file,$description) = split " " , $a ;
if ((upper($description) =~ /TEXT\/PLAIN/) and
(upper($the_file) =~ /PART/)) { # ... a text part
open(PART,"$temp_dir/$the_file") ; # ... drop to MBODY
print MBODY $a while ($a=) ;
close PART ;
unlink "$temp_dir/$the_file" ;
}else{ # ... es attach.
#print MBODY "\n attached file : $the_file" ;
print MBODY "\n archivo adjunto : $the_file" ;
# ... get the file type
$cmd = "$file $temp_dir/$the_file" ;
$out_cmd = `$cmd` ;
chomp $out_cmd ;
$kind = substr( $out_cmd , length("$temp_dir/$the_file")+1) ;
#print MBODY "\n apparently $kind\n";
print MBODY "\n aparentemente $kind\n";
$ext = &upper(&get_extension($the_file)) ;
&guess_extension unless ($ext_known{$ext}) ;
$the_file_out = $the_file ;
# ... eliminate percent and other unwanted characters
$the_file_out =~ s/%/_/g ;
$the_file_out =~ s/X/x/g ;
$the_file_out = $pid.$the_file_out ;
if ($xtended) { # ... guessed extension ?
# ... add extension to the name
$the_file_out = "$the_file_out.$xtended" ;
}#if
print MBODY " $http/$the_file_out\n" ;
print MBODY "\n\n" ;
# ... move the attachment file to $dir_attach
system "mv $temp_dir/$the_file $dir_attach/$the_file_out" ;
}#if
}#if
}#while
# ... clean up
rmdir $temp_dir ;
close PACK ; unlink "$TempBody.aux" ;
close TMPNVO ; unlink $TempBodyNew ;
close MBODY ;
send_mail() ;
exit ;
################################################################
# send mail
################################################################
sub send_mail {
open(MBODY,"$MailBody") || die "$MailBody: $!";
open (ML, "| '$sendmail' $recip") ;
print ML $a while ($a=) ; close ML ;
close MBODY ; unlink $MailBody ;
}#sub ;
################################################################
# guess extension
################################################################
sub guess_extension{
my ($apro_1, $apro_2, $apro_3) ;
$xtended = "" ;
($apro_1, $apro_2, $apro_3) = split " " , $kind ;
if($ext_known{$apro_1}){
$xtended = $ext_supposed{$apro_1} ;
}elsif ($apro_1 eq "PC"){
if ($ext_supposed2{$apro_2}){
$xtended = $ext_supposed2{$apro_2} ;
}#if
}elsif ($apro_1 eq "MPEG"){
if ($ext_supposed2{$apro_2}){
$xtended = $ext_supposed{$apro_2} ;
}else{
$xtended = "mp3" ;
}#if
# ... individual cases
}elsif ($kind =~ /Microsoft Word/ ) { $xtended = "doc"
}elsif ($kind =~ /MS Windows Help Data/ ) { $xtended = "hlp"
}elsif ($kind =~ /MS Windows PE 32-bit/ ) { $xtended = "exe"
}elsif ($kind =~ /Rich Text Format/ ) { $xtended = "rtf"
}elsif ($kind =~ /WAVE audio/ ) { $xtended = "wav"
}elsif ($kind =~ /Rich Text Format/ ) { $xtended = "rtf"
}elsif ($kind =~ /WAVE audio/ ) { $xtended = "wav"
}elsif ($kind =~ /Standard MIDI data/ ) { $xtended = "mid"
}#if
}#sub
################################################################
# upper
################################################################
sub upper {
my $string = $_[0] ;
$string =~ tr/a-z/A-Z/ ; $string ;
}#sub
################################################################
# get file extension
################################################################
sub get_extension{
my @partes ; my $arch = $_[0];
$arch =~ s/\./\:\.\.\:/g ;
@partes = split ":\.\.:" , $arch ;
$partes[scalar(@partes)-1];
}#sub
################################################################
# load extensions
################################################################
sub load_extensions{
%ext_known = (# ... no problem: let it go
AU => 1 ,BMP => 1 ,BZ2 => 1 ,COM => 1 ,DOC => 1 ,EXE => 1,
FIG => 1 ,GIF => 1 ,GZ => 1 ,HLP => 1 ,HQX => 1 ,SB => 1,
HTM => 1 ,HTML=> 1 ,JPEG=> 1 ,JPG => 1 ,MIDI=> 1 ,SDW => 1,
MP3 => 1 ,MPEG=> 1 ,PDF => 1 ,PL => 1 ,PNG => 1 ,SEA => 1,
PPM => 1 ,PS => 1 ,RM => 1 ,RPM => 1 ,RTF => 1 ,TAR => 1,
TEX => 1 ,TGZ => 1 ,TIF => 1 ,WPD => 1 ,XPM => 1 ,ZIP => 1,
XLS => 1 ,TIFF=> 1 );
# ... first word guess
%ext_supposed =(
BZ2 => "bzip2" ,FIG => "fig" ,GIF => "gif" ,GZ => "gzip" ,
JPEG=> "jpg" ,PDF => "pdf" ,PNG => "png" ,PPM => "ppm" ,
RPM => "rpm" ,TGZ => "gzip" ,TIF => "TIFF" ,ZIP => "zip",
TEX => "LaTeX" ,PS => "PostScript" ,RM => "RealMedia",
SB => "SoundBlaster", HTML => "html" ,TIFF => "TIF");
# ... second word guess
%ext_supposed2 =
( bitmap => "bmp" ,color => "cpt" ,video => "mpeg" ,
system => "mpg" );
}#sub
################################################################
# open files
################################################################
sub open_files{
$TempBody = "/tmp/body.$pid" ;
open(TMP,">$TempBody") || die "$TempBody: $!";
$TempBodyNew = "/tmp/cuerponvo.$pid" ;
open(TMPNVO,">$TempBodyNew") || die "$TempBodyNew: $!";
$MailBody = "/tmp/cuerpo2.$pid" ;
open(MBODY,">$MailBody") || die "$MailBody: $!";
}#sub
################################################################
# update log
################################################################
sub update_log{
my $fecha = `date` ;
chomp($fecha) ;
open(CL,">>$log_file") ;
print CL "$fecha $sender -> $dest_user $send\n" ;
close CL ;
}#sub
################################################################
# get sender
################################################################
sub get_sender {
my $dummy ;
if (index($_,"<") >= 0 ){
($dummy,$sender) = split ("<",$_) ;
($sender,$dummy) = split (">",$sender) ;
}else{
($dummy,$sender) = split (" ",$_) ;
}#if
($s_user,$s_machine) = split ("\@",$sender) ;
$recip = $sender ; # by default, the recipient is the sender
}#sub
################################################################
# get destino
################################################################
sub get_dest {
my ($dummy, $dest) ;
if (index($_,"<") >= 0 ){
($dummy,$dest) = split ("<",$_) ;
($dest,$dummy) = split (">",$dest) ;
}else{
($dummy,$dest) = split (" ",$_) ;
}#if
($dest_user,$dummy) = split ("\@",$dest) ;
}#sub