[Roma.pm] problema script perl
Luca Marchesan
l.marchesan at srmsitalia.interbusiness.it
Wed Mar 23 04:33:19 PDT 2011
Ciao ragazzi, questa lista dà supporto a chi come me non ne sa nulla di
perl ma deve risolvere un problema relativo ad uno script?
Spero di si, così vi espongo il problema:
sul mail server che da poco mi trovo ad amministrare c'è uno script
chiamato mailshrink che svolge le seguenti funzioni:
1. elimina dal testo tutte le parti inutili
2. se la mail ha una allegato e questo non è zippato, lo zippa
3. se il valore scritto nel file .withattach è impostato a 0, prende
l'allegato, lo strippa dalla mail, lo stora su /var/spool/srv/mails ed
inserisce nel testo della mail il link per scaricarlo.
Problema: abbiamo rilevato che diverse mail, non tutte, anzichè essere
"ottimizzate" dallo script, vengono completamente cancellate. Restano
solo intestazioni e allegati. In pratica il client visualizza solo
mittente, destinatario e allegato.
Bisognerebbe eliminare dallo script la funzione di ottimizzazione del
testo (punto 1) e lasciare solo le funzioni relative agli allegati
(punti 2 e 3).
Vi allego lo script (mailshrink.txt), il testo della mail (input) che
data in pasto a mailshrink viene sbiancata e il testo dell'output di
mailshrink (output).
Mi potete dare una mano?
Grazie in ogni caso
Luca
-------------- next part --------------
#!/usr/bin/perl -w
=head1 NAME
mailshrink - remove superfluous text from email
=head1 SYNOPSIS
someprocess | mailshrink [-o output_dir] -
=head1 DESCRIPTION
mailshrink - remove superfluous text from email
=head1 COMMAND LINE OPTIONS
=over 8
=item B<-o> <output_dir>
output dir for decoded attachments.
=back
=head1 AUTHOR
Andreas Koenig suggested this, and wrote the original code.
Eryq perverted the hell out of it
Luca Berruti <lberruti at publinet.it>
=cut
use strict;
use Getopt::Std;
use Archive::Zip qw( :ERROR_CODES :CONSTANTS );
use constant {
BASE_URL => 'https://151.99.248.212/mails',
BASE_OUTPUT_DIR => '/var/spool/srv/mails',
RANDOM_LENGTH => 10,
CFG_FILE => '.withattach',
};
use vars qw($opt_o);
use MIME::Parser;
use String::Random;
use File::Basename;
use Cwd;
sub shrink_header {
my @fields = ('Date', 'From', 'To', 'Cc', 'Subject', 'Message-ID', 'In-Reply-To');
my @mime_fields = ('Content-Type', 'Content-Transfer-Encoding',
'MIME-Version');
my ($header, $show_mime) = @_;
$show_mime = 0 unless ($show_mime);
push(@fields, @mime_fields) if $show_mime;
foreach(@fields) {
my $field = $header->get($_);
print "$_: " . $field if $field;
}
print "\n";
1;
}
sub zip_me {
my $path = shift;
my ($filename, $dirname, $suffix) = fileparse($path);
if (($path =~ /\.(zip|rar|7z)$/) ||
($filename eq "") ||
($dirname eq "")) {
return $path
}
my $old_pwd = getcwd();
chdir $dirname;
my $zip = Archive::Zip->new();
$zip->addFile($filename);
my $zip_name = $filename . '.zip';
if ( $zip->writeToFileNamed($zip_name) == AZ_OK ) {
$path = $dirname.$zip_name;
}
chdir $old_pwd;
return $path;
}
sub content_as_link {
my $path = shift;
my $size = ($path ? (-s $path) : '???');
my $url = $path;
$url =~ s/^${\(BASE_OUTPUT_DIR)}/${\(BASE_URL)}/;
$url =~ s/\s/%20/g;
my $contents = sprintf(
"This is an attachment, %d bytes long.\n" .
"It is stored on %s.\n\n",
$size, $path ? $url : 'core');
return Data => $contents;
}
sub content_as_zip {
my $path = shift;
return Path => $path,
Type => "application/zip",
Encoding => "base64";
}
#------------------------------
#
# recurse_entity ENTITY, NAME
#
# Recursive routine for processing an entity.
#
sub recurse_entity {
my ($entity, $show_text, $with_attach) = @_;
$show_text = 0 unless ($show_text);
# Get MIME type...
my ($type, $subtype) = split('/', $entity->head->mime_type);
# Output the body:
my @to_keep = ();
my $entity_ref = \$entity;
my @parts = $entity->parts;
if (@parts) { # multipart...
my $i;
foreach $i (0 .. $#parts) {
push(@to_keep,
recurse_entity($parts[$i], $i == 0 ? 1 : 0, $with_attach));
# XXX alternative are losts...
last if ($subtype =~ /^alternative$/);
}
# delete unneeded parts...
$entity_ref = \$entity->parts(\@to_keep);
} else { # single part...
unless ($show_text && ($type =~ /^(text|message)$/)) {
my $body = $entity->bodyhandle;
my $path = zip_me($body->path);
$body->purge unless ($path eq $body->path);
my %content = $with_attach ?
content_as_zip($path) : content_as_link($path);
$entity_ref = \$entity->attach(%content);
}
}
return $$entity_ref;
}
sub one_time_string {
my $length = shift;
my $passwd = new String::Random;
my $randregex = sprintf('[A-Za-z0-9]{%d}', $length);
return $passwd->randregex($randregex);
}
sub with_attach {
open(F, "$ENV{HOME}/" . CFG_FILE) or return 0;
my @lines = <F>;
close(F);
chomp($lines[0]);
return $lines[0] eq '1' ? 1 : 0;
}
sub main {
print STDERR "(reading from stdin)\n" if (-t STDIN);
# Usage?
# $ARGV[0] or die <<EOF;
#
#Usage:
# mimeencode [-d] encoding <infile >outfile
#
#EOF
getopts("o:");
my $otp = one_time_string(RANDOM_LENGTH);
my $output_dir = ($opt_o ? $opt_o : BASE_OUTPUT_DIR . '/' . $otp);
$CFG::with_attach = with_attach();
umask 0007;
# Create a new MIME parser:
my $parser = new MIME::Parser;
# Create and set the output directory:
(-d $output_dir) or mkdir $output_dir,0770 or die "mkdir: $!";
(-w $output_dir) or die "can't write to directory";
$parser->output_dir($output_dir);
# first line: mbox header file
my $line = <STDIN>;
print $line;
#MIME::Tools->debugging(1);
# Read the MIME message:
my $entity = $parser->read(\*STDIN) or die "couldn't parse MIME stream";
shrink_header($entity->head, 1);
recurse_entity($entity, 1, $CFG::with_attach);
$entity->print_body(\*STDOUT);
}
exit(&main ? 0 : -1);
1;
-------------- next part --------------
An embedded message was scrubbed...
From: Toscano Angelo <angelo.toscano at telecomitalia.it>
Subject: I: iPPCC Authentication
Date: Mon, 21 Mar 2011 14:50:03 +0100
Size: 64426
URL: <http://mail.pm.org/pipermail/roma/attachments/20110323/72f4eaea/attachment-0002.mht>
-------------- next part --------------
An embedded message was scrubbed...
From: Toscano Angelo <angelo.toscano at telecomitalia.it>
Subject: I: iPPCC Authentication
Date: Mon, 21 Mar 2011 14:50:03 +0100
Size: 1025
URL: <http://mail.pm.org/pipermail/roma/attachments/20110323/72f4eaea/attachment-0003.mht>
More information about the Roma
mailing list