#!/usr/bin/perl -w
###########################################################################
### Strips attachments out of email messages (of certain types)
### and replaces them with HTML links
###
### For documentation and latest versions see:
### http://detach.optimism.cc/
###
### This program by and copyright Ryan Hamilton ,
### and Jason Fesler
### all rights reserved
###
### Edited by Jack Zielke and
### Bobby Burden
### http://linuxcoffee.com/detach
###########################################################################
###
### THIS SOFTWARE IS PROVIDED "AS-IS" WITHOUT WARRANTY OF ANY KIND.
###
###########################################################################
### $Id: detach.pl 213 2011-09-14 15:14:41Z jzielke $
###########################################################################
package Detach;
use strict;
use Log::Log4perl qw(:easy);
use Data::Dumper;
use File::Basename;
use MIME::Parser;
use POSIX qw(strftime);
use Number::Bytes::Human qw(format_bytes);
use Digest::MD5 qw(md5_base64);
sub new {
my $class = shift;
my $self = {};
my $args = shift;
my %ARGS = map { $_ => 1 } qw(aggressive web_root dir_root hash shorten msize);
DEBUG(Dumper(\%ARGS));
DEBUG(Dumper($args));
for my $key (keys %$args) {
if (!$ARGS{$key}) {
die "ERROR: invalid option '$key'\n";
}
$self->{$key} = $args->{$key};
}
for my $required (qw(web_root dir_root) ) {
if (! $self->{$required} ) {
die "ERROR: required option '$required' not specified\n";
}
}
bless $self, $class;
my $stamp;
if (! $self->{hash}) {
$stamp = strftime("%Y/%m/%d/%H:%M:%S-$$",localtime);
} else {
# use jfesler's hash based stamp
my $hash = '';
do {
$hash .= md5_base64(join("",time,$$,$<,$>,$self));
$hash =~ s/[^a-zA-Z0-9]//g; # Really, I want base 62
$hash =~ tr/vVO0Il12Z5S/vV/sd; # And, avoid pain with visual cut/paste,
# now base 53
} while (length($hash) < 10); # Just in case
$stamp= substr($hash,0,2) . # 168287943181908783 combos 53^10 - 2(53^9)
"/" . substr($hash,2,8);
}
$self->{dir_root} .= "/$stamp/";
$self->{web_root} .= "/$stamp/";
$self->{dir_root} =~ s|//|/|g;
$self->{web_root} =~ s|([^:])//|$1/|g;
$self->{detached} = [];
$self->{urls} = [];
$self->{firsts} = {};
$self->{cids} = {};
DEBUG(Dumper($self));
return $self;
}
sub detach_message {
my $self = shift;
my $parser = new MIME::Parser;
$parser->output_under("/tmp");
$parser->extract_uuencode(1);
my $envelope = ;
my $entity = $parser->parse(\*STDIN);
#$entity->dump_skeleton(\*STDERR); # for debugging
$self->detach_all($entity);
### if we're in aggressive mode, we need to
### add the blurb to all text/* parts
$self->append_blurbs($entity) if $self->{aggressive};
print $envelope;
$entity->print();
system("/bin/rm", "-rf", $parser->output_dir());
if (@{$self->{detached}}) {
$self->print_index($entity->head()->get('From'),
$entity->head()->get('Subject'));
}
}
### If we're in aggressive mode, we need to append
### the detachment blurb to the first "part"
### for each text/* mime type
sub append_blurbs {
my $self = shift;
my($entity) = @_;
DEBUG("appending blurbs ".Dumper([ keys %{$self->{firsts}}]));
if (@{$self->{urls}}) {
DEBUG("got urls");
if (!scalar keys %{$self->{firsts}}) {
DEBUG("There are detachments and nothing to append the blurb to. Creating empty text/plain.");
my $part = build MIME::Entity (
Type => 'text/plain; charset=us-ascii',
Data => '',
Encoding => 'quoted-printable',
);
$entity->add_part($part, 0);
$self->{firsts}{'text/plain'} = $part;
}
foreach my $m (keys %{$self->{firsts}}) {
DEBUG($m);
my $e = $self->{firsts}{$m};
my $body = $e->bodyhandle;
my @lines = $body->as_lines;
next unless ($body);
DEBUG(" ready to append $m");
my $lines = $self->append_blurb($m,\@lines);
if (!$lines) {
print STDERR "got no lines when appending blurb $m\n";
}
if ($lines) {
my $b = new MIME::Body::InCore $lines;
if ($b) {
$e->bodyhandle($b) ;
} else {
DEBUG("Failed to update body part with index while allocating new MIME::Body::InCore");
}
}
}
}
}
sub append_blurb {
my $self = shift;
my($type,$lines) = @_;
DEBUG("appending blurb of type $type");
my $header = "The following attachments have been detached and are available for viewing.";
my $footer = "Only click these links if you trust the sender, as well as this message.";
my $footer2 = "Note: Attachments will be deleted after 30 days.";
if ($type =~ m#text/plain#) {
return $self->append_blurb_plain($header, $footer, $footer2, $lines);
} elsif ($type =~ m#text/html#) {
return $self->append_blurb_html($header, $footer, $footer2, $lines);
} elsif ($type =~ "text/(rich|enriched)#") {
return $self->append_blurb_rtf($header, $footer, $footer2, $lines);
}
}
sub append_blurb_plain {
my $self = shift;
my($header, $footer, $footer2, $lines) = @_;
my @blurb = ("\n\n\n",
" --- 8< --- detachments --- 8< ---\n",
" $header\n",
map(" $_\n", (@{$self->{urls}})),
" $footer\n",
" $footer2\n",
" --- 8< --- detachments --- 8< ---\n",
"\n");
push(@$lines, @blurb);
return $lines;
}
sub append_blurb_html {
my $self = shift;
my($header, $footer, $footer2, $lines) = @_;
my @blurb = ("Detachments - $header\n",
"
",);
foreach(@{$self->{urls}}) {
my $pretty_url = $_;
$pretty_url =~ s/\%([A-Fa-f0-9]{2})/pack('C', hex($1))/seg;
push (@blurb, "- $pretty_url\n");
my $cid = $self->{cids}{$_};
if ($cid) {
$cid =~ /<(.+)>/;
$cid = $1;
my $url = $_;
DEBUG("Replacing cid:$cid with $url");
foreach (@$lines) {
$_ =~ s#cid:$cid#$url#g;
}
}
}
push(@blurb, ("
$footer
\n",
"$footer2\n",
"",));
DEBUG("Adding html blurb: ". join("\n", @blurb));
my $found=0;
foreach my $line (@$lines) {
if ($line =~ m#
From: $from\nSubj: $subj\n
\n";
for (@{$self->{detached}}) {
my $u = substr($_,length($self->{dir_root}));
$u =~ s/([^A-Za-z0-9])/sprintf("%%%02X", ord($1))/seg;
my $b = basename($_);
my $size = format_bytes((stat($_))[7]);
print F "- $b";
print F " - $size
\n";
}
print F "
\n";
close(F);
}
###########################################################################
package main;
use strict;
use Getopt::Long;
use Log::Log4perl qw(:easy);
$|=1;
umask(0000);
my($opt_web, $opt_dir, $opt_verbose, $opt_help, $opt_aggressive, $opt_hash, $opt_shorten, $opt_size);
if (!GetOptions("d|dir-root=s" => \$opt_dir,
"w|web-root=s" => \$opt_web,
"a|aggressive" => \$opt_aggressive,
"s|shorten" => \$opt_shorten,
"hash" => \$opt_hash,
"size=s" => \$opt_size,
"v|verbose" => \$opt_verbose,
"h|help" => \$opt_help) || $opt_help) {
print STDERR <easy_init($opt_verbose ? $DEBUG : $INFO);
DEBUG("Web root : $opt_web");
DEBUG("Dir root : $opt_dir");
my $detach = new Detach( { dir_root => $opt_dir,
web_root => $opt_web,
aggressive => $opt_aggressive,
shorten => $opt_shorten,
msize => $opt_size,
hash => $opt_hash });
$detach->detach_message();