Re: [rlug] extragere automata a attachurilor dintr-un mail

[Liviu Daia]

Liviu Daia <[EMAIL PROTECTED]> scria la data de 24 Octombrie 2005:
> Octavian Rasnita <[EMAIL PROTECTED]> scria la data de 24 Octombrie 2005:
> >     Email::MIME::Attachment::Stripper - Strip the attachments from a mail
> > 
> >             my $stripper = Email::MIME::Attachment::Stripper->new($mail);
> >             my Email::MIME $msg = $stripper->message;
> >             my @attachments       = $stripper->attachments;
> > 
> > Trebuie instalat Email::MIME::Attachment::Stripper de pe CPAN.
> 
>     Si asta face "extragere automata a attachurilor dintr-un mail"?
> 
>     In sfarsit, daca vrei sa ne taiem in perlane --- dar nu cred ca e
> mai simplu...

    Scuze, am uitat ca RLUG taie attachment-urile care nu sunt text...

    Salutari,

    Liviu Daia

-- 
Dr. Liviu Daia                                  http://www.imar.ro/~daia

#! /usr/bin/perl -w
#
# $Revision$
# $Id$
# $Source$
#

use MIME::Parser;

use strict;
use Carp ();
local $SIG{__WARN__} = \&Carp::cluck;


use constant BUFSIZ => 8192;

my ($p, $f, $e, $b, $buf);


sub attach ($);

sub
attach ($)
{
  my ($e) = @_;

  if ($e->is_multipart)
  {
    # recurse
    for ($e->parts) { attach ($_) }
  }
  else
  {
    $f = '<unknown>';
    $f = $e->head->mime_attr ('content-type.name')
      if (defined $e->head->mime_attr ('content-type.name'));
    $f = $e->head->mime_attr ('content-disposition.filename')
      if (defined $e->head->mime_attr ('content-disposition.filename'));
    # print "attachment: $f\n";

    if ($f =~ m/\.t?gz$/io)
    {
      # sanitize
      $f =~ s/[EMAIL PROTECTED]:,.-]/_/go;
      open F, "> $f"
        or die qq{can't open: $!};

      # $b = IO::Wrap
      $b = $e->bodyhandle->open ('r')
        or die qq{can't open body: $!};
      while ($b->read ($buf, BUFSIZ))
      {
        print F $buf;
      }
      $b->close
        or die qq{can't close body: $!};

      close F
        or die qq{can't close: $!};
    }
  }
}



$p = MIME::Parser->new ();
$p->extract_encoded_messages (1);
$p->extract_nested_messages ('REPLACE');
$p->extract_uuencode (1);
$p->ignore_errors (1);
$p->output_to_core (0);
$p->tmp_recycling (1);
$p->tmp_to_core (0);
$p->use_inner_files (0);

$f = MIME::Parser::FlatFiler->new (defined $ENV{'TMP'} ? $ENV{'TMP'} : '/tmp');
$f->ignore_filename (1);
$p->filer ($f);

$e = eval { $p->parse (\*STDIN) };
die [EMAIL PROTECTED] if ($@ or ! defined $e);
# my $r = $p->results;
eval { attach ($e); };
die [EMAIL PROTECTED] if ($@);

$p->filer->purge;


_______________________________________________
RLUG mailing list
RLUG@lists.lug.ro
http://lists.lug.ro/mailman/listinfo/rlug