perl-modperl mailing list archives

Site index · List index
Message view « Date » · « Thread »
Top « Date » · « Thread »
From Graf László <graf.las...@axis.hu>
Subject Re: mod_perl 2.0 - redirect
Date Thu, 06 Apr 2006 11:52:16 GMT
The module's source:

#file:Wimap/Wimap.pm
#----------------------
package Wimap::Wimap;

use strict;
use warnings;

use Apache2::Const -compile => qw(OK);
use Apache2::Log;
use Apache2::RequestIO ();
use Apache2::RequestRec ();
use Apache2::RequestUtil ();
use Apache2::ServerRec ();
use Apache2::SubRequest ();
use AppConfig qw/:argcount/;
use Data::Dumper;
use IO::File;
use MIME::WordDecoder;
use Mail::IMAPClient;
use ModPerl::MethodLookup;

sub datum
{
my $str = $_[0];
my $pattern = "(.+?), (.*?) (.*?) (.*?) (.*?):(.*?):(.*?) [+/-](.*?)";
my $nap_szoveg = '';
my $nap = '';
my $honap = '';
my $ev = '';
my $idopont = '';

if($str =~ m|^.$pattern.$|s)
{
$nap_szoveg = $1||'';
$nap = $2||'';
$honap = $3||'';
$ev = $4||'';
$idopont = $5.':'.$6.':'.$7;
return $ev.". ".$honap." ".$nap.". ".$idopont;
}
else
{
return $str;
}
}

sub handler {

my $config = AppConfig->new();
my $r = shift;
$r->content_type("text/html");
my $log = $r->server->log;

my $hint;
my @modules;
($hint, @modules) = ModPerl::MethodLookup::lookup_method("lookup_uri");

#$log->error(" Wimap: hint '".$hint."'");
$log->error(" Wimap: document_root '".$r->document_root."'");

my $file = $r->document_root."/wimap/index.html";
#$log->error(" Wimap: file '".$file."'");

open(ALLOMANY, ">$file") || die "HIBA ! A(z) muuu.html allomany nem 
nyithato meg. {$!}";
print(ALLOMANY "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.0 
Transitional//EN\">\n<html>\n<head>\n");
print(ALLOMANY "<meta http-equiv=\"Content-Type\" content=\"text/html; 
charset=iso-8859-2\">\n");
print(ALLOMANY "<title>wimap</title>\n");
print(ALLOMANY "<link rel=\"stylesheet\" href=\"index.css\">\n");
print(ALLOMANY "</head>\n");
print(ALLOMANY "<body>\n");

$config->define("EXPUNGE" => { ARGCOUNT => ARGCOUNT_NONE,DEFAULT => 1 },
"SAVEDIR" => { ARGCOUNT => ARGCOUNT_ONE, DEFAULT => "/home/grafl/imap" },
"VERBOSE" => { ARGCOUNT => ARGCOUNT_NONE,DEFAULT => 0 },
"BACKUP" => { ARGCOUNT => ARGCOUNT_NONE,DEFAULT => 0 },
"HOST" => { ARGCOUNT => ARGCOUNT_ONE, DEFAULT => "imap_server_name" },
"AUTHINFO" => { ARGCOUNT => ARGCOUNT_ONE, DEFAULT => "~/.authinfo" },
"PORT" => { ARGCOUNT => ARGCOUNT_ONE, DEFAULT => 143 },
"USER" => { ARGCOUNT => ARGCOUNT_ONE, DEFAULT => "username" },
"PASSWORD" => { ARGCOUNT => ARGCOUNT_ONE, DEFAULT => "password" },
"MAILBOX" => { ARGCOUNT => ARGCOUNT_ONE, DEFAULT => "INBOX" },
"TO" => { ARGCOUNT => ARGCOUNT_ONE },
"N" => { ARGCOUNT => ARGCOUNT_ONE },
"DUMP" => { ARGCOUNT => ARGCOUNT_NONE },
"CRAMMD5" => { ARGCOUNT => ARGCOUNT_NONE },
# Dangerous!!!
"DELETE_MAILBOX_REALLY" => { ARGCOUNT => ARGCOUNT_NONE, DEFAULT => 0 },
"EXPUNGE_OFTEN" => { ARGCOUNT => ARGCOUNT_NONE, DEFAULT => 0 },
);

$config->args();

my $filename = $config->AUTHINFO;
my $afh = new IO::File(glob($filename));

if ($afh)
{
while (my $auth = <$afh>)
{
my %values;
foreach my $keyword (qw/machine login password port/)
{
if ($auth =~ m/$keyword\s+(\S+)/)
{
$values{$keyword} = $1;
}
}
$values{machine} = "" unless defined $values{machine}; # avoid the undef 
comparison
next unless $config->HOST() eq $values{machine};
$config->USER($values{login}) if exists $values{login};
$config->PASSWORD($values{password}) if exists $values{password};
$config->PORT($values{port}) if exists $values{port};
}
}

# returns a new, authenticated Mail::IMAPClient object
my $imap = Mail::IMAPClient->new(Server => $config->HOST(),
User => $config->USER(),
Port => $config->PORT(),
Password => $config->PASSWORD(),
Peek => 1,
) or die "Cannot connect: $@";

if ($config->CRAMMD5())
{
my $authmech = "CRAM-MD5";
if ($imap->has_capability($authmech))
{
print(ALLOMANY "Switching to $authmech authentication\n");
$imap->Authmechanism($authmech);
}
}

my $count = 0;

if ($config->DELETE_MAILBOX_REALLY)
{
$imap->delete($config->MAILBOX) or warn "Could not delete mailbox " . 
$config->MAILBOX . "\n";
}
elsif ($config->BACKUP)
{
my $dir = $config->SAVEDIR;
die "Can't access directory $dir for writing" unless -d $dir && -w $dir;
my @folders = $imap->folders;
foreach my $f (@folders)
{
next if $f =~ /^\./;
$imap->select($f);
unless (-d "$dir/$f")
{
mkdir "$dir/$f" or die "Couldn't create folder $dir/$f";
}
my @msg_list = $imap->search('UNDELETED');
print(ALLOMANY "Saw message list [@msg_list]\n") if $config->VERBOSE;
foreach my $message (@msg_list)
{
my $filename = "$dir/$f/$message";
next if -e $filename;
print(ALLOMANY "saving message $f/$message to $filename\n") if 
$config->VERBOSE;
my $data_fh = new IO::File $filename, "w";
my $data = $imap->message_string($message);
warn "Empty message data for $f/$message" unless defined $data && length 
$data;
$data_fh->print(ALLOMANY $data);
}
}
}
else
{
my $wd = default MIME::WordDecoder;
$wd = supported MIME::WordDecoder "ISO-8859-2";
$imap->select($config->MAILBOX);
my @msg_list = $imap->search('UNSEEN');
my @sorszam = @msg_list;
print(ALLOMANY "<h4>Saw message list [@msg_list]\n</h4>\n") if 
$config->VERBOSE;
print(ALLOMANY "<table border=\"0\" cellspacing=\"1\" cellpadding=\"4\" 
bgcolor=\"#cccccc\" align=\"center\">\n");
print(ALLOMANY "<tr>\n");
print(ALLOMANY "<th class=\"td_kek\">\&nbsp;</th>\n");
print(ALLOMANY "<th class=\"td_kek\">Cím</th>\n");
print(ALLOMANY "<th class=\"td_kek\">Tárgy</th>\n");
print(ALLOMANY "<th class=\"td_kek\">Időpont</th>\n");
print(ALLOMANY "</tr>\n");
foreach my $message (@msg_list)
{
$count++;
print(ALLOMANY "<tr>");
my $data = $imap->parse_headers($message, "Subject", "From", "Date");
my $address = $data->{From}->[0];
my $subject = $data->{Subject}->[0];
my $date = $data->{Date}->[0];

$subject = $wd->decode($subject);
print(ALLOMANY "<td class=\"td_feher\">".$count."</td>\n");
$address = $1
if ($address =~ m/[<"]?([^\s@]+@[^\s@>"]+)"?>?/);
print(ALLOMANY "<td class=\"td_feher\">".$address."</td>\n");
print(ALLOMANY "<td class=\"td_feher\">".((defined 
$data->{Subject}->[0]) ? $subject : '')."</td>\n");
print(ALLOMANY "<td class=\"td_feher\">".datum($date)."</td>\n");
if ($config->DUMP)
{
my $string = $imap->body_string($message) or die "Could not 
body_string($message): $@\n";
print "\n===\n\n$string\n===\n\n<br>";
}
if ($config->TO)
{
die "Could not move message $message: $!" unless 
$imap->move($config->TO, $message);
print "Moved message $message to " . $config->TO, "\n";
$imap->expunge() if $config->EXPUNGE_OFTEN;
last if $count >= $config->N;
}
print(ALLOMANY "</tr>\n");
}
if ($config->TO)
{
$imap->expunge();
}
}
print(ALLOMANY "</table>\n");
print(ALLOMANY "</body>\n");
close(ALLOMANY);
$r->internal_redirect("/wimap/index.html");
return Apache2::Const::OK;
}

1;

Graf László



Sean Davis wrote:
> I think it would help if you could give some more information (like how you
> are writing the index.html file).  Some code?
>
> Sean
>
>
> On 4/6/06 7:32 AM, "Graf László" <graf.laszlo@axis.hu> wrote:
>
>   
>> Hi all,
>>
>> I made a mod_perl 2.0 module that connects to an IMAP server,
>> retrieves the undeleted mails and generates HTML output.
>>
>> OK, it works fine. When I access 'http://localhost/wimap',
>> the module generates the content and displays it.
>>
>> But what if I want to write the output into a file in the
>> Apache2's document root? Let's name the output file index.html.
>>
>> Now, if I access 'http://localhost/wimap/index.html', all my
>> log messages are written 11 times and it complains that the
>> request exceeded the limit of 10 internal redirects.
>>
>> " Request exceeded the limit of 10 internal redirects due
>>   to probable configuration error. Use 'LimitInternalRecursion'
>>   to increase the limit if necessary. Use 'LogLevel debug' to
>>   get a backtrace."
>>
>> My httpd.conf contains these lines:
>>
>> LoadModule perl_module modules/mod_perl.so
>> PerlRequire /usr/local/apache2/conf/mod_perl/imap_start.pl
>> <Location /wimap>
>>     SetHandler perl-script
>>     PerlResponseHandler Wimap::Wimap
>> </Location>
>>
>> Thank you,
>>     
>
>   

Mime
View raw message