[Roma.pm] Roma Digest, Vol 64, Issue 13

Luca Marchesan l.marchesan at srmsitalia.interbusiness.it
Mon Mar 28 03:37:54 PDT 2011


Ragazzi, scusatemi ma credo di aver fatto una cazzata non dandovi i
giusti input e output.
A questo punto vi incollo più sotto nuovamente il testo dello script e
invio dal mio account gmail a questo indirizzo una mail che viene
"sbiancata" dallo script stesso. Arriverà inviando da dominio gmail?

Grazie ancora,
Luca

############INIZIO script "mailshrink":

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

###################FINE script



Il giorno mer, 23/03/2011 alle 12.00 -0700, roma-request at pm.org ha
scritto:
> Send Roma mailing list submissions to
> 	roma at pm.org
> 
> To subscribe or unsubscribe via the World Wide Web, visit
> 	http://mail.pm.org/mailman/listinfo/roma
> or, via email, send a message with subject or body 'help' to
> 	roma-request at pm.org
> 
> You can reach the person managing the list at
> 	roma-owner at pm.org
> 
> When replying, please edit your Subject line so it is more specific
> than "Re: Contents of Roma digest..."
> 
> 
> Today's Topics:
> 
>    1. Re: problema script perl (Leo Cacciari)
>    2. Re: problema script perl (Christoph Wernli)
> 
> 
> ----------------------------------------------------------------------
> 
> Message: 1
> Date: Wed, 23 Mar 2011 12:52:01 +0100
> From: Leo Cacciari <leo.cacciari at gmail.com>
> To: roma at pm.org
> Subject: Re: [Roma.pm] problema script perl
> Message-ID: <4D89DEE1.40005 at gmail.com>
> Content-Type: text/plain; charset="utf-8"
> 
> Il 03/23/2011 12:33 PM, Luca Marchesan ha scritto:
> > 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
> >
> >
> > _______________________________________________
> > Roma mailing list
> > Roma at pm.org
> > http://mail.pm.org/mailman/listinfo/roma
> Ciao,
> da quello che capisco a una prima occhiata, direi che non dipende dallo
> script ma dall'abitudine di alcuni clienti di posta elettronica che
> mandano il testo della mail in un attacment mime (in realt? due
> attacment, uno di tipo txt l'altro di tipo html). Infatti se guardi
> nella directory di output, trovi che il testo della mail ? l?: nel file
> msg-9711-1.txt (e c'? una copia nel formato html in msg-9711-2.html).
> 
> TH
> 
> -- 
> Leo Cacciari
> Aliae nationes servitutem pati possunt populi romani est propria libertas
> 
> -------------- next part --------------
> An HTML attachment was scrubbed...
> URL: <http://mail.pm.org/pipermail/roma/attachments/20110323/10650ae0/attachment-0001.html>
> 
> ------------------------------
> 
> Message: 2
> Date: Wed, 23 Mar 2011 13:02:33 +0100
> From: Christoph Wernli <cwernli at gmail.com>
> To: roma at pm.org
> Subject: Re: [Roma.pm] problema script perl
> Message-ID: <C823A659-E0CC-47A6-9064-23EFDAB32014 at gmail.com>
> Content-Type: text/plain; charset=iso-8859-1
> 
> On Mar 23, 2011, at 12:52 PM, Leo Cacciari wrote:
> 
> > Infatti se guardi nella directory di output, trovi che il testo della mail ? l?: nel file msg-9711-1.txt (e c'? una copia nel formato html in msg-9711-2.html).
> 
> 
> E da questo segue: meglio proteggere correttamente le directory che contengono delle mail, altrimenti tutto il mondo le va a leggere...
> 
> -Christoph
> 




More information about the Roma mailing list