home *** CD-ROM | disk | FTP | other *** search
/ rtsi.com / 2014.01.www.rtsi.com.tar / www.rtsi.com / OS9 / FAQ / discus_admin_1357211388 / source / em-reply.pl < prev    next >
Text File  |  2009-11-06  |  11KB  |  348 lines
  1. # FILE: em-reply.pl
  2. # DESCRIPTION: Reply by e-mail
  3. #-------------------------------------------------------------------------------
  4. # DISCUS COPYRIGHT NOTICE
  5. #
  6. # Discus is copyright (c) 2002 by DiscusWare, LLC, all rights reserved.
  7. # The use of Discus is governed by the Discus License Agreement which is
  8. # available from the Discus WWW site at:
  9. #    http://www.discusware.com/discus/license
  10. #
  11. # Pursuant to the Discus License Agreement, this copyright notice may not be
  12. # removed or altered in any way.
  13. #-------------------------------------------------------------------------------
  14.  
  15. use strict;
  16. use vars qw($GLOBAL_OPTIONS $PARAMS $DCONF);
  17.  
  18. ###
  19. ### reply_pipe_input
  20. ###
  21. ### For piping data into e-mail reply script
  22. ###
  23.  
  24. sub reply_pipe_input {
  25.     error_message("Access Error", "This script cannot be accessed via the World Wide Web", 0, 1) if $ENV{'REQUEST_METHOD'} ne "";
  26.     error_message("Access Error", "This script cannot be accessed via the World Wide Web", 0, 1) if $ENV{'REMOTE_ADDR'} ne "";
  27.     my $buf = "\0" x 1024;
  28.     my $text = "";
  29.     if ($ARGV[0] eq "") {
  30.         binmode STDIN;
  31.         while (length($buf) == 1024) {
  32.             read(STDIN, $buf, 1024);
  33.             $text .= $buf;
  34.         }
  35.     }
  36.     $text eq "" ? email_reply_pop3_handler() : email_reply_text_handler($text);
  37.     program_exit(0);
  38. }
  39.  
  40. ###
  41. ### email_reply_pop3_handler
  42. ###
  43. ### Checks POP3 mailbox and then runs the handler
  44. ###
  45.  
  46. sub email_reply_pop3_handler {
  47.     pop3_retrieve(@_);
  48.     my $dir = join("/", $DCONF->{admin_dir}, "data", "pop3_in");
  49.     opendir(DIR, $dir);
  50.     my @dir = map {"$dir/$_"} grep {not /^\.\.?$/} readdir DIR;
  51.     closedir(DIR);
  52.     foreach my $file (@dir) {
  53.         next if ! -f $file;
  54.         my $tmp = $/; undef $/;
  55.         open (FILE, "< $file");
  56.         my $rf = <FILE>;
  57.         close (FILE);
  58.         $/ = $tmp;
  59.         unlink $file;
  60.         email_reply_text_handler($rf);
  61.     }
  62. }
  63.  
  64. ###
  65. ### email_reply_text_handler
  66. ###
  67. ### Handles incoming messages, posting them as appropriate
  68. ###
  69.  
  70. sub email_reply_text_handler {
  71.     my ($text) = @_;
  72.     my $DEBUG = 1;
  73.     my $textnew = $text;
  74.     $text =~ s/\r\n/\n/g; $text =~ s/\r/\n/g;
  75.     my ($header_text, $body) = split(/\n\n/, $text, 2);
  76.     my $headers = parse_mail_headers($header_text);
  77.     my $hash = parse_mail_body($body);
  78.     if ($DEBUG) {
  79.         my $char = $DCONF->{'debug_email_reply_append'} ? ">>" : ">";
  80.         open (DEBUGFILE, "$char $DCONF->{admin_dir}/data/debug-email-reply");
  81.         print DEBUGFILE "--------------------------------------------------------------\n";
  82.         print DEBUGFILE "Message received at ", scalar localtime(time), "\n";
  83.         print DEBUGFILE "--------------------------------------------------------------\n";
  84.         while ($textnew =~ /^(.{1,40})/s) {
  85.             $textnew = $';
  86.             my $x = $1;
  87.             $x =~ s/(.)/sprintf("%02x", ord($1))/ges;
  88.             print DEBUGFILE $x, "\n";
  89.         }
  90.         print DEBUGFILE "--------------------------------------------------------------\n";
  91.         print DEBUGFILE "Headers:\n\n";
  92.         print DEBUGFILE $header_text, "\n";
  93.         print DEBUGFILE "-" x 60, "\n";
  94.         print DEBUGFILE "Body:\n\n";
  95.         print DEBUGFILE $body, "\n";
  96.         print DEBUGFILE "-" x 60, "\n";
  97.         print DEBUGFILE "Header List:\n";
  98.         foreach my $k (keys(%{ $headers })) {
  99.             print DEBUGFILE "$k -> '$headers->{$k}'\n";
  100.         }
  101.         print DEBUGFILE "-" x 60, "\n";
  102.         print DEBUGFILE "Body List:\n";
  103.         foreach my $k (keys(%{ $hash })) {
  104.             if ($k eq "message") {
  105.                 print DEBUGFILE "$k -> length ", length($hash->{$k}), "\n";
  106.             } else {
  107.                 print DEBUGFILE "$k -> '$hash->{$k}'\n";
  108.             }
  109.         }
  110.         if (ref $hash->{'codes'} eq 'ARRAY') {
  111.             print DEBUGFILE "Administer from here codes:\n";
  112.             foreach my $z (@{ $hash->{'codes'} }) {
  113.                 print "Code =: $z\n";
  114.             }
  115.         }
  116.         print DEBUGFILE "-" x 60, "\n";
  117.         print DEBUGFILE "Message Text:\n";
  118.         print DEBUGFILE "'$hash->{'message'}'\n";
  119.         close (DEBUGFILE);
  120.     }
  121.     return undef if $headers->{'x-mailer'} =~ /^Discus/;
  122.     my $frh = {};
  123.     $frh->{username} = $hash->{username};
  124.     $frh->{COOKIE}->{cpwd} = $hash->{password};
  125.     $frh->{COOKIE}->{rpwd} = "xxxxxxxx";
  126.     $frh->{password} = "adminlogin";
  127.     $frh->{topic} = $hash->{topic};
  128.     $frh->{page} = $hash->{page};
  129.     $frh->{passwd} = "xxxxxxxx";
  130.     if ($hash->{'topic'} eq "0") {
  131.         dreq("authpass");
  132.         my $result = check_password($frh->{username}, $frh->{password}, { type_required => 'moderator' }, $frh->{COOKIE});
  133.         if ($result->[0]->{'user'} eq $DCONF->{superuser}) {
  134.             dreq("mailer", "template");
  135.             my $par = email_configuration_read();
  136.             my $mm = {};
  137.             $mm->{general}->{test} = 1;
  138.             my $txt = templ_int("testmail", $mm);
  139.             send_email_message({ to => $par->{test_email_address}, subject => read_language()->{EMAIL_NOTIFICATION_TEST_SUBJECT} }, $txt, $par);
  140.         }
  141.     } else {
  142.         if ($DCONF->{pro}) {
  143.             dreq("em-admin-PRO");
  144.         }
  145.         my $flag = $DCONF->{pro} ? email_perform_commands($hash, $headers, $frh) : 1;
  146.         $flag *= $hash->{is_message};
  147.         if ($flag) {
  148.             dreq("posting");
  149.             my %qp_headers = map { lc($_), 1 } ('quoted-printable', '8bit');
  150.             if ($GLOBAL_OPTIONS->{always_quoted_printable} || defined $qp_headers{lc($headers->{'content-transfer-encoding'})}) {
  151.                 $hash->{message} =~ s/=(\s)/$1/g;
  152.                 $hash->{message} =~ s/=([A-F0-9][A-F0-9])/chr(hex($1))/gie;
  153.             }
  154.             $frh->{message} = $hash->{message}; ##remove_html($hash->{message});
  155.             if ($frh->{message} =~ /\\\w+\{/) {
  156.                 $frh->{active_links} = 0;
  157.             } else {
  158.                 $frh->{active_links} = 1;
  159.                 $frh->{message} = remove_html($hash->{message});
  160.             }
  161.             $frh->{html} = 0;
  162.             $PARAMS->{no_exit} = sub {
  163.                 my ($errormsg) = @_;
  164.                 if ($headers->{from} =~ /([\w\+\-\.]+)\@([\w\+\-\.]+)/) {
  165.                     my $subst = {};
  166.                     my $addr = $&;
  167.                     dreq("mailer", "template");
  168.                     $errormsg =~ s%<h3>(.*?)</h3>%$1\n\n%gi;
  169.                     $errormsg = remove_html($errormsg);
  170.                     $subst->{general}->{failed} = $errormsg;
  171.                     $subst->{general}->{topic} = $frh->{topic};
  172.                     $subst->{general}->{page} = $frh->{page};
  173.                     my $text = templ_int("erfailed", $subst);
  174.                     send_email_message({ to => $addr, subject => uc(read_language()->{EMAIL_REPLY_FAILED}) }, $text);
  175.                 }
  176.                 program_exit(0);
  177.             };
  178.             my $pc = posting_control(undef, $frh);
  179.             $PARAMS->{no_exit} = undef;;
  180.             if ($pc eq "OK") {
  181.                 return 1;
  182.             }
  183.         }
  184.     }
  185. }
  186.  
  187. ###
  188. ### parse_mail_body
  189. ###
  190. ### Determines parameters from the message
  191. ###
  192.  
  193. sub parse_mail_body {
  194.     my ($text_in) = @_;
  195.     my %out = {};
  196.     my $toparrow = quotemeta '--\/--\/--\/--\/--\/--\/--\/--\/--\/--\/--\/--';
  197.     my $botarrow = quotemeta '--/\--/\--/\--/\--/\--/\--/\--/\--/\--/\--/\--';
  198.     if ($text_in =~ /$toparrow(.*?)$botarrow/s) {
  199.         my ($beforemessage, $message, $aftermessage) = ($`, $1, $');
  200.         $out{'sane'} = 1;
  201.         $message =~ s/<br[^>]*>/\n/gi;  ## So HTML formatted messages can work
  202.         $message = $1 if $message =~ /\n+(.*)\n+/s;  ## For newline after top arrow and before bottom arrow
  203.         my @msgline = split(/\n/, $message);
  204.         $out{'is_message'} = 1;
  205.         $out{'is_message'} = 0 if $msgline[0] =~ /\[.*\]\s*$/ && scalar(@msgline) == 1;
  206.         my @portions = split(/\n\n/, $message);
  207.         foreach my $portion (@portions) {
  208.             $portion =~ s/\s+/ /g;
  209.         }
  210.         $out{'message'} = join("\n\n", @portions);
  211.         if ($DCONF->{pro}) {
  212.             dreq("em-admin-PRO");
  213.             $out{'codes'} = email_scan_for_commands($beforemessage, $aftermessage);
  214.         }
  215.         if ($aftermessage =~ m|/(\d+)/(\d+)/(\d+)/([^\s\/]+)/(\S+)\s*\n|) {
  216.             $out{'topic'} = $1;
  217.             $out{'page'} = $2;
  218.             $out{'post'} = $3;
  219.             $out{'username'} = $4;
  220.             $out{'password'} = $5;
  221.             $out{'password'} =~ s/<.*?>//g;
  222.         }
  223.     } elsif ($text_in =~ m|/0/0/0/([^\s\/]+)/(\S+)\s*\n|) {
  224.         $out{'topic'} = '0';
  225.         $out{'username'} = $1;
  226.         $out{'password'} = $2;
  227.         $out{'password'} =~ s/<.*?>//g;
  228.     } elsif ($DCONF->{pro}) {
  229.         dreq("em-admin-PRO");
  230.         $out{'codes'} = email_scan_for_commands($text_in);
  231.         if ($text_in =~ m|/(\d+)/(\d+)/(\d+)/([^\s\/]+)/(\S+)\s*\n|) {
  232.             $out{'topic'} = $1;
  233.             $out{'page'} = $2;
  234.             $out{'post'} = $3;
  235.             $out{'username'} = $4;
  236.             $out{'password'} = $5;
  237.             $out{'password'} =~ s/<.*?>//g;
  238.         }
  239.         $out{'is_message'} = 0;
  240.     }
  241.     return \%out;
  242. }
  243.  
  244. ###
  245. ### parse_mail_headers
  246. ###
  247. ### Reads mail headers and dumps them into an array
  248. ###
  249.  
  250. sub parse_mail_headers {
  251.     my ($text) = @_;
  252.     my @lines = split(/\n/, $text);
  253.     my %out = {};
  254.     foreach my $line (@lines) {
  255.         if ($line =~ /([^:]+):\s*(.*\S)\s*$/) {
  256.             my ($key, $val) = (case_lower($1), $2);
  257.             $out{$key} = $val;
  258.         }
  259.     }
  260.     return \%out;
  261. }
  262.  
  263. ###
  264. ### pop3_retrieve
  265. ###
  266. ### Retrieves appropriate messages from a POP3 mailbox, and deletes the
  267. ### messages it's retrieved.
  268. ###
  269.  
  270. sub pop3_retrieve {
  271.     my ($param) = @_;
  272.     my $pop3_user = defined $param->{user} ? $param->{user} : $GLOBAL_OPTIONS->{pop3_user};
  273.     my $pop3_pass = defined $param->{pass} ? $param->{pass} : $GLOBAL_OPTIONS->{pop3_pass};
  274.     my $pop3_host = defined $param->{host} ? $param->{host} : $GLOBAL_OPTIONS->{pop3_host};
  275.     my $scan = defined $param->{scan} ? $param->{scan} : $GLOBAL_OPTIONS->{pop3_scan};
  276.     my $addr = defined $param->{addr} ? $param->{addr} : $GLOBAL_OPTIONS->{pop3_addr};
  277.     my $as_text = defined $param->{as_text} ? $param->{as_text} : 0;
  278.     my $pop = eval '
  279.         use Net::POP3;
  280.         my $pop = Net::POP3->new($pop3_host, Timeout => 30);
  281.         $pop; ';
  282.     if (! defined $pop) {
  283.         if ($@ ne "") {
  284.             log_error("em-reply.pl", "pop3_retrieve", "Initialization of POP3 connect object failed on this error: $@");
  285.         } else {
  286.             log_error("em-reply.pl", "pop3_retrieve", "Could not connect to POP3 host '$pop3_host' (unknown reason; perhaps a timeout occurred)");
  287.         }
  288.         return 1;
  289.     }
  290.     my $msg_count = $pop->login($pop3_user, $pop3_pass);
  291.     if (! defined $msg_count) {
  292.         log_error("em-reply.pl", "pop3_retrieve", "Could not log in to POP3 host '$pop3_host' (username/password was probably incorrect)");
  293.         $pop->quit();
  294.         return 2;
  295.     }
  296.     $pop->quit() if $msg_count == 0;
  297.     return 0 if $msg_count eq "0E0";
  298.     return 2 if $msg_count == 0;
  299.     my @result = ();
  300.     if ($scan) {
  301.         my $qaddr = quotemeta($addr);
  302.         for (my $i = 1; $i <= $msg_count; $i++) {
  303.             my $j = $pop->top($i, 0);
  304.             next if ! grep(/^to:.*$qaddr/i, @{ $j });
  305.             push @result, $i;
  306.         }
  307.     } else {
  308.         @result = ( 1 .. $msg_count );
  309.     }
  310.     my $dir = join("/", $DCONF->{admin_dir}, "data", "pop3_in");
  311.     if (! $as_text) {
  312.         if (! -e $dir) {
  313.             mkdir($dir, oct($DCONF->{perms0777})) || error_message("Directory Creation Error", "Could not create incoming POP3 directory");
  314.             chmod(oct($DCONF->{perms0777}), $dir);
  315.         }
  316.     }
  317.     my @out = ();
  318.     my $uidl = {};
  319.     $uidl = $pop->uidl() if ! $as_text;
  320.     foreach my $msg_get (@result) {
  321.         if (! $as_text) {
  322.             $uidl->{$msg_get} =~ s%\W%%g;
  323.             my $filename = join("/", $dir, $uidl->{$msg_get});
  324.             my $tries = 0;
  325.             while (-e $filename) {
  326.                 $filename .= int(rand(10));
  327.                 $tries++;
  328.                 error_message("File Creation Error", "Could not create a unique file name for incoming POP3 message $uidl->{$msg_get}", 0, 1) if $tries > 10;
  329.             }
  330.             my $u = $pop->get($msg_get);
  331.             next if ref $u ne 'ARRAY';
  332.             open (FH, "> $filename");
  333.             print FH @{$u};
  334.             close (FH);
  335.             $pop->delete($msg_get);
  336.             push @out, @{$u};
  337.         } else {
  338.             my $u = $pop->get($msg_get);
  339.             push @out, @{$u} if ref $u eq 'ARRAY';
  340.             $pop->delete($msg_get);
  341.         }
  342.     }
  343.     $pop->quit();
  344.     return \@out;
  345. }
  346.  
  347. 1;
  348.