mailto:-Aktion.sendmail-Programms voraus.GET-Request aufgerufen; der Parameter
FormURL muß die URL des Formulars enthalten:
http://server/cgi-path/FormMail.pl?FormURL=relative_form_URL
FORM METHOD wird auf POST gesetztFORM ACTION wird auf das Skript selbst gesetztFormURL wird als
HIDDEN-Feld hinzugefügtSUBMIT-Button.
POST-Request aufgerufen; die Parameter
enthalten die Formular-Eingaben.
CGI
vereinfacht u.a. den Zugriff auf die Parameter, mit denen das Skript
aufgerufen wurde:
use CGI;
my $cgi = new CGI;
my $form_url = $cgi->param('FormURL');
Im Skript selbst wird der Export-Set ':html' benutzt, um
HTML-Ausgaben über die Funktionsschnittstelle von CGI zu
machen. Die Objektschnittstelle wird benutzt, da für Debug-Zwecke die
Funktionalität new(\*FILEHANDLE) genutzt wird.
Da der Parameter FormURL nur dem Skript selbst dient, würde
er bei der weiteren Verarbeitung nur stören. Daher wird er aus der Liste
der Parameter gelöscht:
$cgi->delete('FormURL');
In Schritt 6 werden alle Eingabe-Werte geholt und gespeichert, wobei
Mehrfachwerte zu einem String mit mehreren Zeilen zusammengefaßt
werden:
my %values;
foreach ($cgi->param)
{
my @val = $cgi->param($_);
$values{$_} = join "\n", @val;
}
URI::URL, LWP::UserAgent, und
HTTP::Request. Diese sind Teil der
libwww-perl (LWP).
use URI::URL;
use LWP::UserAgent;
use HTTP::Request;
sub abs_url
{
# Erweitern einer URL zu einer absolute URL
url( url( $_[0] )->path, $base_url )->abs->as_string;
}
$serverName = $cgi->server_name;
if ($serverName =~ /^(?:\d+\.)+\d+$/)
{
use Socket;
# Der Servername liegt als IP-Adresse vor.
# Im folgenden wird er - wenn möglich - in einen Hostnamen verwandelt.
my $s = gethostbyaddr inet_aton($serverName), AF_INET;
$serverName = $s if defined $s;
}
$base_url = "http://$serverName/";
my $url = abs_url( $form_url );
# Abrufen des Inhalts
my $ua = new LWP::UserAgent;
$ua->agent( "$0/$VERSION" );
my $request = HTTP::Request->new( GET => $url );
my $response = $ua->simple_request( $request );
$response->is_success gibt Auskunft darüber, ob die
Abfrage erfolgreich war, $response->content enthält den
Inhalt der Formular-Seite.
Der Umweg, die Formular-Seite per HTTP zu laden, wurde gewählt, um die Verwendung von Webserver-Konstrukten (SSI, ASP u.ä.) zu ermöglichen, und um möglichen Sicherheitslücken vorzubeugen.
HTML::Parser. Es stellt eine Basisklasse zur Verfügung,
von der man ableiten kann. Da das Skript nicht unnötig auf mehrere
Dateien verstreut werden sollte, wurde die abgeleitete Klasse
FormMail in das Skript integriert:
{
package FormMail;
use vars qw(@ISA $AUTOLOAD);
use HTML::Parser;
@ISA = 'HTML::Parser';
# ...
}
my $cgi_url = abs_url( $cgi->url );
my $fmp = FormMail->new( $cgi_url, $form_url );
$fmp->set_values( \%values );
$fmp->parse( $response->content );
$fmp->eof;
Die Methode new der Klasse FormMail
initialisiert die Variablen des Objekts und blesst die
Objekt-Variable:
sub new
{
my ($class, $myurl, $formurl) = @_;
my $self = $class->SUPER::new;
$self->{FMsender} = '';
$self->{FMsubject} = '';
$self->{FMsuccess_url} = '';
$self->{FMfailure_url} = '';
$self->{FMprocess} = '';
$self->{FMpre_results} = '';
$self->{FMpost_results} = '';
$self->{FMrecipient} = '';
$self->{FMmy_url} = URI::URL::url( $myurl )->path;
$self->{FMform_url} = URI::URL::url( $formurl )->path;
$self->{FMelements} = [];
$self->{FMfields} = [];
$self->{FMvalues} = \0;
bless $self, $class;
}
Außerdem wird eine Methode AUTOLOAD definiert, um lesenden
Zugriff auf diese Variablen zu gestatten:
sub AUTOLOAD
{
my ($self) = @_;
return if $AUTOLOAD =~ /::DESTROY$/;
$AUTOLOAD =~ s/^FormMail::/FM/;
die "No such variable '$AUTOLOAD'"
if !exists $self->{$AUTOLOAD};
return $self->{$AUTOLOAD};
}
Die Methode set_values übergibt die Eingabe-Parameter an
die Klasse:
sub set_values
{
my ($self, $values) = @_;
$self->{FMvalues} = $values;
}
Die Methoden parse und eof werden von
HTML::Parser gererbt.
Während des Parsens werden von HTML::Parser Methoden
aufgerufen, welche die abgeleitete Klasse überladen kann (und sollte, um
etwas Sinnvolles zu tun - in der Basisklasse sind diese Methoden leer). Sie
stehen für die verschiedenen Typen von Elementen, die in einem
HTML-Dokument vorkommen können:
declarationstartendtextcommentFMelements ein Array aus anonymen
Arrays aufgebaut. Deren erstes Element enthält den Namen des
HTML-Elements bzw. Typ des Nicht-HTML-Elements; alle weiteren Elemente
enthalten Zusatzinformationen, z.B. für Markup-Deklarationen:
sub declaration
{
my ($self, $decl) = @_;
push @{$self->{FMelements}}, ['DECL', $decl];
}
(Da die Namen von HTML-Tags den Methoden start und end
stets in Kleinbuchstaben übergeben werden, wurde beschlossen, zur
besseren Unterscheidung alle vom Skript generierten Namen in
Großbuchstaben auszuführen.)
Bei einem öffenden HTML-Tag ist zu prüfen, ob es sich um das Tag
FORM handelt, um die unter Schritt 3 genannten Änderungen
am Kopf des Formulars und in demselben vornehmen zu können. Die
Hash-Referenz $attr enthält die Attribute des Tags und
deren Werte.
sub start
{
my ($self, $tag, $attr) = @_;
if ($tag eq 'form')
{
$attr->{action} =~ /^mailto:(\S+)/i
or die "FormMail form requires a 'mailto' action";
$self->{FMrecipient} = $1;
# METHOD auf POST umschreiben
$attr->{method} = 'POST';
# ACTION auf uns selbst umschreiben
$attr->{action} = $self->{FMmy_url};
push @{$self->{FMelements}}, [$tag, $attr];
# Verstecktes FormURL-Feld einfügen
push @{$self->{FMelements}},
[
'INPUT',
{
type => 'hidden',
name => 'FormURL',
value => $self->{FMform_url}
}
];
}
else
{
push @{$self->{FMelements}}, [$tag, $attr];
if ( (($tag eq 'input' && $attr->{type} !~ /^(?:submit|reset)$/i)
|| $tag =~ /^(?:textarea|select)$/)
&& defined $attr->{name})
{
push @{$self->{FMfields}}, $attr->{name};
}
}
}
Gleichzeitig wird hier das Array FMfields aufgebaut, das
die Namen aller Eingabefelder des Formulars enthält (bzw.
letztendlich die Namen derjenigen Felder, die in die E-Mail aufgenommen
werden).
Bei einem schließenden HTML-Element und bei Text ist nicht mehr zu
tun, als es in den Array FMelements aufzunehmen:
sub end
{
my ($self, $tag) = @_;
push @{$self->{FMelements}}, ['END', $tag];
}
sub text
{
my ($self, $text) = @_;
push @{$self->{FMelements}}, ['TEXT', $text];
}
Befehle an FormMail.pl sind in HTML-Kommentaren enthalten. Die allgemeine Form
ist <!--!Kommando!Parameter-->. Die implementierten
Kommandos sind:
requirednot_requiredrequired_ifname eq/ne wert. Die Eingabefelder müssen
ausgefüllt werden, wenn der boolsche Ausdruck wahr istnot_required_ifname eq/ne wert. Die Eingabefelder müssen
nicht ausgefüllt werden, wenn der boolsche Ausdruck wahr
ist
senderFrom:-FeldsubjectSubject:-Feldpre_resultspost_resultsTo:-Feld wird aus der FORM ACTION des
Formulars bestimmt.
processFormMail::process dieses Skripts
aufgerufen, und eine Referenz auf FMfields
und FMvalues übergeben (die sie auch
verändern kann). Liefert die Routine einen falschen Wert
zurück, wird das Formular erneut ausgegeben.success_urlfailure_urlonly_if_first_timeonly_if_missing_requiredonly_if_process_fails
sub comment
{
my ($self, $comment) = @_;
my ($command, $parameter) = ($comment =~ /^!(\w+)!(.*)$/s);
if ($command)
{
$command = lc $command;
if ($command =~
/^(?:sender|
subject|
success_url|
failure_url|
process|
pre_results|
post_results
)$/x)
{
for ($parameter) { s/^\s+//; s/\s+$//; }
$self->{"FM$command"} = $parameter;
}
elsif ($command =~ /^(?:not_)?required$/)
{
push @{$self->{FMelements}}, ['CMD', $command];
}
elsif ($command =~ /^(?:not_)?required_if$/)
{
for ($parameter) { s/^\s+//; s/\s+$//; }
push @{$self->{FMelements}}, ['CMD', $command, $parameter];
}
elsif ($command =~
/^(?:only_if_missing_required|
only_if_first_time|
only_if_process_fails)
$/x)
{
push @{$self->{FMelements}}, ['CMD', $command, $parameter];
}
else
{
die "Error: '$command' is not a valid FormMail command";
}
}
else
{
push @{$self->{FMelements}}, ['CMNT', $comment];
}
}
FMelements, und a) das Umschalten eines Flags, wenn ein
Kommando (not_)?required(_if)? angetroffen wird, und b) das
Prüfen dieses Flags und des Werts, wenn ein Eingabe-Element angetroffen
wird:
sub required_ok
{
my ($self) = @_;
my $value = $self->{FMvalues};
my $is_required = $::default_is_required;
for my $element (@{$self->{FMelements}})
{
my ($tag, $attr, $param) = @$element;
if ($tag eq 'CMD')
{
if ($attr eq 'required_if')
{
$is_required = _eval_expression( $param, $value );
}
elsif ($attr eq 'not_required_if')
{
$is_required = ! _eval_expression( $param, $value );
}
elsif ($attr eq 'required')
{
$is_required = 1;
}
elsif ($attr eq 'not_required')
{
$is_required = 0;
}
}
elsif ( $is_required
&& (($tag eq 'input' && $attr->{type} !~ /^(?:submit|reset)$/i)
|| $tag =~ /^(?:textarea|select)$/)
&& defined $attr->{name}
&& !$value->{$attr->{name}})
{
return 0
}
}
return 1;
}
Den Evaluation-Engine traue ich mich kaum einzufügen, so trivial ist er
bis jetzt &smiley;
sub _eval_expression
{
my ($expression, $value) = @_;
my ($var, $op, $val) = split /\s+/, $expression, 3;
my $result = eval "defined \$value->{\$var} && (\$value->{\$var} $op '\$val')";
die "Error in expression \"$expression\": $@\n" if $@;
return $result;
}
sub process_ok ($)
{
use FindBin;
my ($self) = @_;
return 1 if !$self->{FMprocess};
my $path = $FindBin::Bin;
$path = VMS::Filespec::unixify( $path ) if $^O eq 'VMS';
my $process = $path . '/' . $self->{FMprocess};
return 0 if !(-f $process && -r _ && require $process);
return FormMail::process( \@{$self->{FMfields}}, $self->{FMvalues} )
}
Die Variable $FindBin::Bin enthält das Verzeichnis, in dem
sich das Skript befindet. Das Modul FindBin ist Bestandteil der
Standard-Distribution.
as_HTML implementiert, welche die
HTML-Seite als String zurückliefert (die Namensgebung ist an das Modul
HTML::Element angelehnt). Diese tut nichts anderes, als den Array
FMelements durchzugehen, und entsprechend dem ersten Element
der Array-Elemente HTML-Teile an den String anzufügen.
In Schritt 9 wird außerdem berücksichtigt, ob die als benötigt gekennzeichneten Eingabe-Felder ausgefüllt wurden, und ob das Post-Processing erfolgreich war. Unterschieden werden die Schritte 9 und 4 hier an der Tatsache, ob diese boolschen Variablen übergeben werden oder nicht.
sub as_HTML
{
my ($self, $required_ok, $process_ok) = @_;
my $is_first_time = !defined $required_ok || !defined $process_ok;
$required_ok = 1 if !defined $required_ok;
$process_ok = 1 if !defined $process_ok;
my $value = undef;
$value = $self->{FMvalues} if !$is_first_time;
my $HTML = '';
my $selectName = '';
my $textareaName = '';
# as this procedure relies on an empty key for recognizing
# select and textarea sections...
delete $value->{''} if exists $value->{''};
ELEMENT:
for my $element (@{$self->{FMelements}})
{
my ($tag, $attr) = @$element;
($tag eq 'CMD') && do
{
if ( ($attr eq 'only_if_first_time' && $is_first_time)
|| ($attr eq 'only_if_missing_required' && !$required_ok )
|| ($attr eq 'only_if_process_fails' && $required_ok && !$process_ok ))
{
$HTML .= $element->[2]; # Insert CMD parameter as TEXT
}
next ELEMENT;
};
($tag eq 'DECL') && do { $HTML .= "<!$attr>"; next ELEMENT; };
($tag eq 'CMNT') && do { $HTML .= "<!--$attr-->"; next ELEMENT; };
($tag eq 'TEXT') && do
{
# supress if text is a textarea default value,
# and the user has entered something into that textarea
$HTML .= $attr
unless $value->{$textareaName};
next ELEMENT;
};
($tag eq 'END') && do
{
$HTML .= "</$attr>";
# reset select/textarea special mode
$selectName = '' if $attr eq 'select';
$textareaName = '' if $attr eq 'textarea';
next ELEMENT;
};
# Default case:
# $tag is a HTML start tag,
# $attr is a hash reference of attributes
my $attrname = $attr->{name}; # the most important attribute
# fill in user's response
if ( $tag eq 'input'
&& defined $attrname
&& defined $value->{$attrname})
{
if ($attr->{type} =~ /^text$/i)
{
$attr->{value} = $value->{$attrname};
}
elsif ($attr->{type} =~ /^(?:radio|checkbox)$/i)
{
# toggle the CHECKED attribute
if ($value->{$attrname} =~ /^$attr->{value}$/m)
{
$attr->{checked} = undef;
}
else
{
delete $attr->{checked};
}
}
}
elsif ($tag eq 'option' && defined $value->{$selectName})
{
# toggle the SELECTED attribute
if ($value->{$selectName} =~ /^$attr->{value}$/m)
{
$attr->{selected} = undef;
}
else
{
delete $attr->{selected};
}
}
elsif ($tag eq 'select' && defined $attrname)
{
$selectName = $attrname; # save for 'option' case
}
elsif ($tag eq 'textarea' && defined $attrname)
{
$textareaName = $attrname; # save for default value
}
# output tag and attributes
$HTML .= "<$tag";
for my $a (keys %$attr)
{
$HTML .= " $a";
$HTML .= "=\"$attr->{$a}\"" if defined $attr->{$a};
}
$HTML .= '>';
# textarea is special in that its value is output as text
if ( $tag eq 'textarea'
&& defined $attrname
&& defined $value->{$attrname})
{
$HTML .= $value->{$attrname};
}
}
return $HTML;
}
Eine spezielle Behandlung genießen hier SELECT- und
TEXTAREA-Elemente, um (in Schritt 9) sicherzustellen, daß
nicht Defaultwerte, sondern diejenigen Werte übernommen werden, die der
Benutzer eingegeben hat.
sendmail implementiert. Dies setzt
allerdings voraus, daß ein Mailhost existiert, der die Mail
entgegennimmt und weiterbefördert. Dabei kommt das Modul
Net::SMTP zum Einsatz, das Teil des
libnet-Pakets ist.
sub send_mail
{
use Net::SMTP;
my ($self, $value) = @_;
my $value = $self->{FMvalues};
# check that all required variables have been filled in
$self->{FMsender} ne '' && $self->{FMrecipient} ne ''
or die "Required mail parameter is missing\n";
# needed on architectures where Net::Domain::_hostname doesn't work
my %options = ( Hello => $::serverName );
$options{Debug} = 1 if $::debug;
my @data = (
"From: $self->{FMsender}\n",
"To: $self->{FMrecipient}\n",
"Subject: $self->{FMsubject}\n",
# This MIME assumption may of course be wrong...
"Mime-Version: 1.0\n",
"Content-Type: text/plain; charset=iso-8859-1\n",
"Content-Transfer-Encoding: 8bit\n",
#
"\n"
);
push @data, $self->{FMpre_results};
my %seen;
for my $e (@{$self->{FMfields}})
{
next if $seen{$e}++ || !exists $value->{$e};
my $blanks = ' ' x length($e);
my @val = split "\n", $value->{$e};
push @data, sprintf "%s: %s\n", $e , (shift @val || '');
push @data, sprintf "%s %s\n", $blanks, shift @val
while @val != 0;
}
push @data, $self->{FMpost_results};
my $smtp = Net::SMTP->new( $::mailHost, %options );
my $success = 0;
if ($smtp)
{
$success = $smtp->mail( $self->{FMsender} );
$success &&= $smtp->recipient( $self->{FMrecipient} );
$success &&= $smtp->data( \@data );
$smtp->quit;
}
warn "Failed to send mail\n" if !$success;
if (!$success && $::failFile)
{
if (open FAILFILE, $::failFile)
{
print FAILFILE '-' x 80, "\n";
print FAILFILE join( '', @data ), "\n";
close FAILFILE;
}
else
{
warn "Failed to save mail either: $!\n";
}
}
return $success;
}
my $request_method = $cgi->request_method();
if ($request_method eq 'GET')
{
# Send the form
print
$cgi->header(-Pragma=>'No-Cache'),
$fmp->as_HTML;
exit;
}
die "REQUEST_METHOD is neither GET nor POST"
unless $request_method eq 'POST';
my $required_ok = $fmp->required_ok();
my $process_ok = $required_ok && $fmp->process_ok();
unless ($required_ok && $process_ok)
{
# Resend the form
print
$cgi->header(-Pragma=>'No-Cache'),
$fmp->as_HTML($required_ok, $process_ok);
exit;
}
unless ($fmp->send_mail())
{
my $furl = $fmp->failure_url;
if ($furl)
{
$furl = abs_url( $furl ) if $furl !~ m!^(?:http|ftp)://!;
print $cgi->redirect( $furl );
}
else
{
# ...Fehlermeldung ausgeben
}
exit;
}
# everything went well, tell the user
my $surl = $fmp->success_url;
if ($surl)
{
$surl = abs_url( $surl ) if $surl !~ m!^(?:http|ftp)://!;
print $cgi->redirect( $surl );
}
else
{
# ...Erfolgsmeldung ausgeben
}