[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