From 51fc77aafe3ce278f9ab2dbf1a4d48214a291798 Mon Sep 17 00:00:00 2001 From: ndparker <> Date: Fri, 30 Mar 2001 22:11:34 +0000 Subject: [PATCH 1/1] CheckRFC now matches a http-uri including the fragment identifier redesign of fo_posting.pl, not yet ready, be patient, please ;-) --- selfforum-cgi/shared/CheckRFC.pm | 2 +- selfforum-cgi/user/config/answer.tmp.xml | 2 +- selfforum-cgi/user/config/fo_posting.xml | 18 +- selfforum-cgi/user/config/fo_view.xml | 2 +- selfforum-cgi/user/config/posting.tmp.xml | 2 +- selfforum-cgi/user/fo_posting.pl | 686 ++++++++-------------- 6 files changed, 264 insertions(+), 448 deletions(-) diff --git a/selfforum-cgi/shared/CheckRFC.pm b/selfforum-cgi/shared/CheckRFC.pm index 6c64ade..35d47d8 100644 --- a/selfforum-cgi/shared/CheckRFC.pm +++ b/selfforum-cgi/shared/CheckRFC.pm @@ -172,7 +172,7 @@ BEGIN { my $hsegment = "(?:(?:$httpuchar|[;:\@&=~])*)"; my $search = "(?:(?:$httpuchar|[;:\@&=~])*)"; my $hpath = "(?:$hsegment(?:/$hsegment)*)"; - my $httpurl = "(?:http://$hostport(?:/$hpath(?:\\?$search)?)?)"; + my $httpurl = "(?:http://$hostport(?:/$hpath(?:\\?$search)?)?(?:#$xchar*)?)"; # GOPHER (see also RFC1436) my $gopher_plus = "(?:$xchar*)"; diff --git a/selfforum-cgi/user/config/answer.tmp.xml b/selfforum-cgi/user/config/answer.tmp.xml index 8ea9c3e..a7d9970 100644 --- a/selfforum-cgi/user/config/answer.tmp.xml +++ b/selfforum-cgi/user/config/answer.tmp.xml @@ -163,7 +163,7 @@ --> {&& %IF _FORM_FUP_VALUE &&} +
{&& %IF _FORM_FUP_VALUE &&} {&& %ENDIF &&}{&& %IF _FORM_UID_VALUE &&} {&& %ENDIF &&} diff --git a/selfforum-cgi/user/config/fo_posting.xml b/selfforum-cgi/user/config/fo_posting.xml index fd6e4fc..d39d8a2 100644 --- a/selfforum-cgi/user/config/fo_posting.xml +++ b/selfforum-cgi/user/config/fo_posting.xml @@ -46,7 +46,7 @@ - /cgi-local/user/fo_posting.pl + /cgi-local/dev/env.pl _FORM_ACTION @@ -69,6 +69,8 @@ posterName posterEmail posterBody + posterCategory + posterSubject @@ -163,7 +165,8 @@ category 18 3 - repeat + fetch + category ASP BROWSER @@ -172,7 +175,7 @@ DATENBANK DESIGN DHTML - E_MAIL + E-MAIL FTP GRAFIK HTML @@ -209,7 +212,8 @@ subject 64 4 - repeat + fetch + subject @@ -237,7 +241,8 @@ url 1024 - repeat + http-url + kill @@ -248,7 +253,8 @@ image 1024 - repeat + http-url + kill diff --git a/selfforum-cgi/user/config/fo_view.xml b/selfforum-cgi/user/config/fo_view.xml index 3b507ad..a647105 100644 --- a/selfforum-cgi/user/config/fo_view.xml +++ b/selfforum-cgi/user/config/fo_view.xml @@ -68,7 +68,7 @@ - /cgi-local/user/fo_posting.pl + /cgi-local/dev/env.pl _FORM_ACTION diff --git a/selfforum-cgi/user/config/posting.tmp.xml b/selfforum-cgi/user/config/posting.tmp.xml index 32b1ce0..67df7b5 100644 --- a/selfforum-cgi/user/config/posting.tmp.xml +++ b/selfforum-cgi/user/config/posting.tmp.xml @@ -38,7 +38,7 @@
{&& _THREAD &&}
{&& %ENDIF &&}

Eigene Antwort schreiben

Die Nachricht, auf die Sie antworten, ist im Feld des Nachrichtentextes noch mal komplett zitiert. Entfernen Sie bei langen Nachrichten bitte alle Passagen aus dem Zitat bis auf jene, auf die Sie selbst Bezug nehmen wollen.

- + {&& %IF _FORM_UID_VALUE &&} {&& %ENDIF &&} diff --git a/selfforum-cgi/user/fo_posting.pl b/selfforum-cgi/user/fo_posting.pl index 9bc7eb0..e59d2c4 100644 --- a/selfforum-cgi/user/fo_posting.pl +++ b/selfforum-cgi/user/fo_posting.pl @@ -1,18 +1,21 @@ -#!/usr/bin/perl +#!/usr/bin/perl -wT ################################################################################ # # # File: user/fo_posting.pl # # # -# Authors: André Malo , 2001-01-25 # +# Authors: André Malo , 2001-03-30 # # # # Description: Accept new postings, display "Neue Nachricht" page # # # +# not ready, be patient please # +# # ################################################################################ use strict; -use vars qw($Bin $Shared $Script %subhash $httpurl $flocked); +use vars qw($Bin $Shared $Script); +# locate the script BEGIN { my $null = $0; $null =~ s/\\/\//g; # for win :-( ($Bin) = ($null =~ /^(.*)\/.*$/)? $1 : '.'; @@ -20,518 +23,325 @@ BEGIN { ($Script) = ($null =~ /^.*\/(.*)$/)? $1 : $null; } -use CGI::Carp qw(fatalsToBrowser); - use lib "$Shared"; +#use CGI::Carp qw(fatalsToBrowser); + use Conf; use Encode::Plain; $Encode::Plain::utf8 = 1; use Encode::Posting; use Id; use Lock qw(:ALL); -use Mail; -use Posting::_lib qw(get_all_threads get_message_node get_message_header hr_time); +use CheckRFC; +use Posting::_lib qw(get_all_threads get_message_node get_message_header hr_time parse_xml_file); use Posting::Write; use Template; use Template::Posting; -use CGI qw(param header); +use CGI; use XML::DOM; -print header (-type => 'text/html'); - -our $conf = read_script_conf ($Bin, $Shared, $Script); - -our $show_posting = $conf -> {show} -> {Posting}; -our $assign = $show_posting -> {assign}; -our $formmust = $show_posting -> {form} -> {must}; -our $formdata = $show_posting -> {form} -> {data}; -our $formact = $show_posting -> {form} -> {action}; -our $template = new Template $show_posting -> {templateFile}; -our $pars = {}; -our ($failed, %dparam, $threads, $last_thread, $last_message, $ftid, $fmid, $flocked); - -sub forum_filename () {$conf -> {files} -> {forum};} -sub message_path () {$conf -> {files} -> {messagePath};} - -################################ +# load script configuration and admin default conf. +my $conf = read_script_conf ($Bin, $Shared, $Script); +my $adminDefault = read_admin_conf ($conf -> {files} -> {adminDefault}); -# Formfelder ausfuellen (Namen) -for (qw(posterBody uniqueID followUp quoteChar userID posterName posterEmail posterCategory posterSubject posterURL posterImage)) { - $pars -> {$formdata -> {$_} -> {assign} -> {name}} = plain($formdata -> {$_} -> {name});} +# Initializing the request +my $response = new Posting::Response ($conf, $adminDefault); -my $checked = &check_param; +# fetch and parse the cgi-params +$response -> parse_cgi; -unless (exists ($subhash {$checked})) { - &print_fatal ($assign -> {unknownError});} - -else { - unless ($checked eq 'newThread') { - $checked = &check_reply_dupe() || $checked;} - - unless (exists ($subhash {$checked})) { - &print_fatal ($assign -> {unknownError});} - else { - &{$subhash {$checked}};} - - if ($flocked) { - violent_unlock_file (forum_filename) unless (write_unlock_file (forum_filename));}} - -# ==================================================== -# end of main / Funktionen -# ==================================================== +################################################################################ +### Posting::Response ########################################################## +package Posting::Response; -### check_reply_dupe () ######################################################## -# -# Reply moeglich? Doppelposting? +### sub new #################################################################### # -# Params: -none- -# Return: Dupe check result -# 'Dupe' - Posting is a dupe -# Nothing - ok. +# initialising the Posting::Response object +# check parameters and fill in object properties # -sub check_reply_dupe () { - my $stat; - - unless ($stat = write_lock_file (forum_filename)) { - if ($stat == 0) { - # ueberlastet oder so - violent_unlock_file (forum_filename); - return 'Occupied'; - } else { - return 'masterLock'; - } - } else { - my ($i, %msg, %unids); - - $flocked = 1; +sub new { + my ($class, $conf, $adminDefault) = @_; - ($threads, $last_thread, $last_message, undef, my $unids) = get_all_threads (forum_filename, 1, 0); - ($ftid,$fmid) = split /;/,$dparam{$formdata -> {followUp} -> {name}},2; + my $sp = $conf -> {show} -> {Posting}; - # Thread existiert nicht - if (exists($dparam{$formdata -> {followUp} -> {name}})) { - return 'noReply' unless (exists($threads -> {$ftid})); + my $self = { + conf => { + original => $conf, + admin => $adminDefault, - # nur nicht geloeschte Messages beachten - for ($i=0; $i < @{$threads -> {$ftid}}; $i++) { - if ($threads -> {$ftid} -> [$i] -> {deleted}) { - $i+=$threads -> {$ftid} -> [$i] -> {answers};} + message_path => $conf -> {files} -> {messagePath}, + forum_file_name => $conf -> {files} -> {forum}, - else { - $msg{$threads -> {$ftid} -> [$i] -> {mid}}=$i;}} + show_posting => $sp, + assign => $sp -> {assign}, + form_must => $sp -> {form} -> {must}, + form_data => $sp -> {form} -> {data}, + form_action => $sp -> {form} -> {action}, + }, - # Message existiert nicht - if (exists($dparam{$formdata -> {followUp} -> {name}})) { - return 'noReply' unless (exists($msg{$fmid}));} - - %unids = map {$_ => 1} @{$threads -> {$ftid} -> [$msg{$fmid}] -> {unids}}; - } else { - %unids = map {$_ => 1} @$unids; - } + template => new Template $sp -> {templateFile} + }; - # jetzt endlich - return 'Dupe' if (exists ($unids{$dparam{$formdata -> {uniqueID} -> {name}}})); - } - - return; + bless $self, $class; } -################################ -# sub got_new +### sub parse_cgi ############################################################## # -# Eroeffnungsposting speichern -################################ - -sub got_new () { - - my $time = time; - my $pars = {author => $dparam {$formdata -> {posterName} -> {name}}, - email => $dparam {$formdata -> {posterEmail} -> {name}}, - category => $dparam {$formdata -> {posterCategory} -> {name}}, - subject => $dparam {$formdata -> {posterSubject} -> {name}}, - body => $dparam {$formdata -> {posterBody} -> {name}}, - homepage => $dparam {$formdata -> {posterURL} -> {name}}, - image => $dparam {$formdata -> {posterImage} -> {name}}, - time => $time, - uniqueID => $dparam {$formdata -> {uniqueID} -> {name}}, - ip => $ENV{REMOTE_ADDR}, - forumFile => forum_filename, - messagePath => message_path, - lastThread => $last_thread, - lastMessage => $last_message, - parsedThreads => $threads, - dtd => 'forum.dtd', - quoteChars => toUTF8('»» '), - messages => $conf -> {template} -> {messages}}; - - my ($stat, $xml, $mid) = write_posting ($pars); - violent_unlock_file (forum_filename) unless (write_unlock_file (forum_filename)); - $flocked = undef; - - if ($stat) { - print "Och noe...: $stat";} - - else { - my $thx = $show_posting -> {thanx}; - - print ${$template -> scrap ($assign -> {docThx}, - {$thx -> {author} => plain ($dparam {$formdata -> {posterName} -> {name}}), - $thx -> {email} => plain ($dparam {$formdata -> {posterEmail} -> {name}}), - $thx -> {time} => plain (hr_time($time)), - $thx -> {body} => message_as_HTML ($xml, $template, - {posting => $mid, - assign => $assign}), - $thx -> {category} => plain ($dparam {$formdata -> {posterCategory} -> {name}}), - $thx -> {home} => plain ($dparam {$formdata -> {posterURL} -> {name}}), - $thx -> {image} => plain ($dparam {$formdata -> {posterImage} -> {name}}), - $thx -> {subject} => plain ($dparam {$formdata -> {posterSubject} -> {name}})})}; - } - return; -} - -################################ -# sub got_reply +# fetch and decode cgi-parameters, +# find out the kind of response requested by the user (new message, reply) # -# Antwortposting speichern -################################ - -sub got_reply () { - my $stat; - - my $time = time; - my $pars = {author => $dparam {$formdata -> {posterName} -> {name}}, - email => $dparam {$formdata -> {posterEmail} -> {name}}, - category => $dparam {$formdata -> {posterCategory} -> {name}}, - subject => $dparam {$formdata -> {posterSubject} -> {name}}, - body => $dparam {$formdata -> {posterBody} -> {name}}, - homepage => $dparam {$formdata -> {posterURL} -> {name}}, - image => $dparam {$formdata -> {posterImage} -> {name}}, - time => $time, - uniqueID => $dparam {$formdata -> {uniqueID} -> {name}}, - ip => $ENV{REMOTE_ADDR}, - parentMessage => $fmid, - thread => $ftid, - forumFile => forum_filename, - messagePath => message_path, - lastThread => $last_thread, - lastMessage => $last_message, - parsedThreads => $threads, - dtd => 'forum.dtd', - quoteChars => toUTF8('»» '), - messages => $conf -> {template} -> {messages}}; - - ($stat, my $xml, my $mid) = write_posting ($pars); - violent_unlock_file (forum_filename) unless (write_unlock_file (forum_filename)); - $flocked = undef; - - if ($stat) { - print "Och noe...: $stat";} - - else { - my $thx = $show_posting -> {thanx}; - - print ${$template -> scrap ($assign -> {docThx}, - {$thx -> {author} => plain ($dparam {$formdata -> {posterName} -> {name}}), - $thx -> {email} => plain ($dparam {$formdata -> {posterEmail} -> {name}}), - $thx -> {time} => plain (hr_time($time)), - $thx -> {body} => message_as_HTML ($xml, $template, - {posting => $mid, - assign => $assign}), - $thx -> {category} => plain ($dparam {$formdata -> {posterCategory} -> {name}}), - $thx -> {home} => plain ($dparam {$formdata -> {posterURL} -> {name}}), - $thx -> {image} => plain ($dparam {$formdata -> {posterImage} -> {name}}), - $thx -> {subject} => plain ($dparam {$formdata -> {posterSubject} -> {name}})})};} -} - -################################ -# sub new_thread +# Return: Status Code (Bool) +# try out the error method, if false # -# HTML fuer Eroeffnungsposting -################################ - -sub new_thread () { - my $list = [map {{$assign -> {optval} => plain($_)}} @{$formdata -> {posterCategory} -> {values}}]; - - # spaeter kommen noch userspezifische Daten dazu... - print ${$template -> scrap ($assign -> {docNew}, - {$formdata->{uniqueID} ->{assign}->{value} => plain(unique_id), - $formdata->{quoteChar} ->{assign}->{value} => 'ÿ'.plain(toUTF8('»» ')), - $formact->{post}->{assign} => $formact->{post}->{url}, - $formdata->{posterCategory}->{assign}->{value} => $template->list ($assign -> {option}, $list) - },$pars)}; -} +sub parse_cgi { + my $self = shift; -################################ -# diverse subs -# -# Fehlermeldungen -################################ - -sub no_reply () {&print_fatal ($assign -> {noReply});} -sub dupe_posting () {&print_fatal ($assign -> {dupe});} -sub missing_key () {&print_fatal ($assign -> {wrongPar});} -sub unexpected_key () {&print_fatal ($assign -> {wrongPar});} -sub unknown_encoding () {&print_fatal ($assign -> {wrongCode});} -sub too_short () { - if ($formdata -> {$failed} -> {errorType} eq 'repeat') { - &print_error ($formdata -> {$failed} -> {assign} -> {tooShort}, - $formdata -> {$failed} -> {minlength});} + # create the CGI object + my $q = new CGI; + $self -> {cgi_object} = $q; - else { - &print_fatal ($formdata -> {$failed} -> {assign} -> {tooShort});} + # check the params + return unless $self -> check_cgi; } -sub too_long () { - if ($formdata -> {$failed} -> {errorType} eq 'repeat') { - &print_error ($formdata -> {$failed} -> {assign} -> {tooLong}, - $formdata -> {$failed} -> {maxlength});} - - else { - &print_fatal ($formdata -> {$failed} -> {assign} -> {tooLong});} -} - -sub wrong_mail () {print_error ($formdata -> {$failed} -> {assign} -> {wrong});} -sub occupied () {print_error ($assign -> {occupied});} - -################################ -# sub print_fatal +### sub check_cgi ############################################################## # -# fatale Fehlerausgabe -################################ - -sub print_fatal ($) { - print ${$template -> scrap ($assign -> {docFatal}, - {$assign -> {errorMessage} => $template -> insert ($_[0]) - },$pars)}; -} - -################################ -# sub print_error +# cgi params are like raw eggs... # -# Fehlerausgabe, Moeglichkeit -# zur Korrektur -################################ - -sub print_error ($;$) { - &fillin; - print ${$template -> scrap ($assign -> {docError}, - {$assign -> {errorMessage} => $template -> insert ($_[0]), - $assign -> {charNum} => $_[1] - },$pars)}; -} - -################################ -# sub fetch_subject +# Return: Status Code (Bool) +# creates content for the error method if anything fails # -# Subject und Category besorgen -# (wenn noch nicht vorhanden) -################################ +sub check_cgi { + my $self = shift; -sub fetch_subject () { - - my %must = map {$_ => 1} @{$formmust -> {exists $dparam{$formdata -> {followUp} -> {name}}?'reply':'new'}}; + # find out the count of the submitted keys and the keys themselves + # + my %got_keys = map {($_ => 1)} $self -> {cgi_object} -> param; + my $cnt_got_keys = keys %got_keys; + my $formdata = $self -> {conf} -> {form_data}; + my $formmust = $self -> {conf} -> {form_must}; - if ( ($must{posterCategory} and not exists ($dparam{$formdata -> {posterCategory} -> {name}})) or - ($must{posterSubject} and not exists ($dparam{$formdata -> {posterSubject} -> {name}}))) - { - my $filename = message_path.'t'.$ftid.'.xml'; + # user requested the 'new thread' page + # (no params or only the user-ID has been submitted) + # + if ($cnt_got_keys == 0 or ( + exists ($formdata -> {userID}) + and $cnt_got_keys == 1 + and $got_keys{$formdata -> {userID} -> {name}} + ) + ) { + $self -> {response} = {new_thread => 1}; + return 1; + } - if (-f $filename and lock_file ($filename)) - { - my $xml = new XML::DOM::Parser -> parsefile ($filename); - violent_unlock_file($filename) unless unlock_file ($filename); + ################################################### + # now we know, we've got a filled out form + # we do the following steps to check it: + # + # 1st: create a reverse Hash (CGI-key - identifier) + # 2nd: did we get _all_ must-keys? + # check whether reply or new message request + # 3rd: did we get too many keys? + # 4th: do _all_ requested values accord to + # expectations? + # fetch the "missing" keys + # - my $mnode = get_message_node ($xml, "t$ftid", "m$fmid"); - my $header = get_message_header ($mnode); + # 1 + # + my %name = map {($formdata -> {$_} -> {name} => $_)} keys %$formdata; - $dparam{$formdata -> {posterCategory} -> {name}} = $header -> {category}; - $dparam{$formdata -> {posterSubject} -> {name}} = $header -> {subject}; - } - } -} + # 2 + # + $self -> {response} -> {reply} = $got_keys {$formdata -> {followUp} -> {name}}? 1 : 0; + $self -> {response} -> {new} = not $self -> {response} -> {reply}; -################################ -# sub fillin -# -# Fuellen von $pars -# (bereits vorhandene Formdaten) -################################ + # define the fetch array (values to fetch from parent message) + # + $self -> {fetch} = []; -sub fillin () { - fetch_subject; + for ( @{$formmust -> {$self -> {response} -> {reply}?'reply':'new'}} ) { - my $list = [map {{$assign -> {optval} => plain($_), - (($_ eq $dparam{$formdata -> {posterCategory} -> {name}})?($assign -> {optsel} => 1):())}} - @{$formdata -> {posterCategory} -> {values}}]; + unless ($got_keys {$formdata -> {$_} -> {name}}) { - $pars -> {$formdata->{posterCategory}->{assign}->{value}} = $template->list ($assign -> {option}, $list); - $pars -> {$formact ->{post}->{assign}} = $formact->{post}->{url}; - $pars -> {$formdata->{quoteChar}->{assign}->{value}} = 'ÿ'.plain($dparam {$formdata -> {quoteChar} -> {name}} or ''); + # only miss the key unless we're able to fetch it from parent posting + # + unless ( + $self -> {response} -> {new} + or $formdata -> {$name {$_}} -> {errorType} eq 'fetch') { - # Formfelder ausfuellen (Werte) - for (qw(uniqueID userID followUp posterName posterEmail posterSubject posterBody posterURL posterImage)) { - $pars -> {$formdata->{$_}->{assign}->{value}} = plain($dparam {$formdata -> {$_} -> {name}});} -} + $self -> {error} = {spec => 'missing_key'}; + return; + } + else { + # keep in mind to fetch the value later + # + push @{$self -> {fetch}} => $name {$_}; + } + } + } -################################ -# sub decode_param -# -# CGI-Parameter decodieren -# (rudimentaerer UTF8-support) -################################ + # 3 + # + for ($self -> {cgi_object} -> param) { + unless (exists ($name {$_})) { + $self -> {error} = { + spec => 'unexpected_key', + desc => $name{$_} + }; + return; + } + } -sub decode_param () { - my $code = param ($formdata -> {quoteChar} -> {name}); - my @array; + # 4 + # + unless ($self -> decode_param) { + $self -> {error} = {spec => 'unknown_encoding'}; + return; + }; - # UTF-8 ([hoechst-]wahrscheinlich) - if ($code =~ /^\303\277/) { + # I'm lazy - I know... + my $q = $self -> {cgi_object}; - foreach (param) { - @array=param ($_); + if ($self -> {response} -> {reply}) { - if (@array == 1) { - $dparam{$_} = $array[0];} + # get the parent-identifiers if we got a reply + # + my ($ftid, $fmid) = split /;/ => $q -> param ($formdata -> {followUp} -> {name}) => 2; - else { - $dparam{$_} = \@array;}}} + unless ($ftid =~ /\d+/ and $fmid =~ /\d+/) { + $self -> {error} = {spec => 'unknown_followup'}; + return; + } + $self -> {fup_tid} = $ftid; + $self -> {fup_mid} = $fmid; - # Latin 1 (hoffentlich - eigentlich ist es gar keine Codierung...) - elsif ($code =~ /^\377/) { - foreach (param) { - @array=param ($_); + # now fetching the missing keys + # if it fails, they're too short, too... ;) + # + $self -> fetch; + } - if (@array == 1) { - $dparam{$_} = toUTF8($array[0]);} + # now we can check on length, type etc. + # + for (keys %got_keys) { - else { - $dparam{$_} = [map {toUTF8($_)} @array];}}} + my $val = $q -> param ($_); - # unbekannte Codierung - else { - return;} + $val =~ s/\302\240/ /g; # convert nbsp to normal spaces + $q -> param ($_ => $val); # write it back - # ersten beiden Zeichen der Quotechars loeschen (Indikator [ÿ (als UTF8)]) - $dparam {$formdata -> {quoteChar} -> {name}} = ($dparam {$formdata -> {quoteChar} -> {name}} =~ /..(.*)/)[0]; + # too long? + # + if (length $val > $formdata -> {$name {$_}} -> {maxlength}) { + $self -> {error} = { + spec => 'too_long', + desc => $name{$_} + }; + return; + } - delete $dparam {$formdata -> {posterURL} -> {name}} - unless ($dparam {$formdata -> {posterURL} -> {name}} =~ /$httpurl/); + # too short? + # (only check if there's defined a minimum length) + # + if (exists ($formdata -> {$name {$_}} -> {minlength})) { + + # kill the whitespaces to get only the visible characters... + # + (my $val_ww = $val) =~ s/\s+//g; + + if (length $val_ww < $formdata -> {$name {$_}} -> {minlength}) { + $self -> {error} = { + spec => 'too_short', + desc => $name{$_} + }; + return; + } + } - delete $dparam {$formdata -> {posterImage} -> {name}} - unless ($dparam {$formdata -> {posterImage} -> {name}} =~ /$httpurl/); +# return 'wrongMail' if ($formdata -> {$name{$_}} -> {type} eq 'email' and length ($dparam{$_}) and not is_mail_address ($dparam{$_})); + } - # Codierung erkannt, alles klar + # ok, looks good. 1; } -################################ -# sub check_param +# delete $dparam {$formdata -> {posterURL} -> {name}} +# unless ($dparam {$formdata -> {posterURL} -> {name}} =~ /$httpurl/); # -# CGI-Parameter pruefen -################################ +# delete $dparam {$formdata -> {posterImage} -> {name}} +# unless ($dparam {$formdata -> {posterImage} -> {name}} =~ /$httpurl/); -sub check_param () { - my %gotKeys = map {($_ => 1)} param; - my $numGotKeys = keys %gotKeys; +### sub fetch ################################################################## +# +# fetch "missing" keys from parent posting +# +sub fetch { + my $self = shift; + my $q = $self -> {cgi_object}; + my $formdata = $self -> {conf} -> {form_data}; - # Threaderoeffnung, Ersteingabe (leere Seite) - return 'newThread' if ($numGotKeys == 0 or - (($numGotKeys == 1) and ($gotKeys {$formdata -> {userID} -> {name}}))); + if (@{$self -> {fetch}}) { + my $filename = $self -> {conf} -> {message_path}.'t'.$self -> {fup_tid}.'.xml'; - # ======================================================= - # ab hier steht fest, wir haben ein ausgefuelltes - # Formular bekommen - # - # 1. Umrechnungshash bauen (CGI-Key => Identifier) - # 2. alle must-keys vorhanden? - # 3. zuviele Parameter uebermittelt? - # 4. entsprechen die Daten den Anforderungen? - # (alle, nicht nur die must-Daten) + if (lock_file ($filename)) { + my $xml = parse_xml_file ($filename); + violent_unlock_file($filename) unless unlock_file ($filename); - # 1 - # === - my %name = map {($formdata -> {$_} -> {name} => $_)} keys %$formdata; + if ($xml) { + my $mnode = get_message_node ($xml, 't'.$self -> {fup_tid}, 'm'.$self -> {fup_mid}); + if ($mnode) { + my $header = get_message_header ($mnode); - # 2 - # === - $failed=1; - foreach (@{$formmust -> {$gotKeys {$formdata -> {followUp} -> {name}}?'reply':'new'}}) { - return 'missingKey' unless ($gotKeys {$formdata -> {$_} -> {name}}); + $q -> param ($formdata -> {$_} -> {name} => $header -> {$formdata -> {$_} -> {header}}) + for (@{$self -> {fetch}}); + } + } + } } - # 3 - # === - foreach (param) { - $failed = $name {$_}; - return 'unexpectedKey' unless (exists ($name {$_})); - } + # fetching failed: + # fillout the values with an empty string + # + $q -> param ($formdata -> {$_} -> {name} => '') + for (@{$self -> {fetch}}); +} - # 4 - # === - return 'unknownEncoding' unless (decode_param); +### sub decode_param ########################################################### +# +# convert submitted form data into UTF-8 +# unless it's not encoded yet +# +# Return: Status Code (Bool) +# false if unknown encoding (like UTF-7 for instance) +# +sub decode_param { + my $self = shift; - foreach (keys %dparam) { - $failed = $name {$_}; + my $q = $self -> {cgi_object}; + my $formdata = $self -> {conf} -> {form_data}; - return 'tooLong' if (length($dparam{$_}) > $formdata -> {$name {$_}} -> {maxlength}); - return 'tooShort' if (@{[$dparam{$_} =~ /(\S)/g]} < $formdata -> {$name {$_}} -> {minlength}); - return 'wrongMail' if ($formdata -> {$name{$_}} -> {type} eq 'email' and length ($dparam{$_}) and not is_mail_address ($dparam{$_})); - } + my $code = $q -> param ($formdata -> {quoteChar} -> {name}); + my @array; - $failed=0; - return $gotKeys {$formdata -> {followUp} -> {name}}?'gotReply':'gotNew'; -} + # Latin 1 (we hope so - there's no real way to find out :-( ) + if ($code =~ /^\377/) { + $q -> param ($_ => map {toUTF8($_)} $q -> param ($_)) for ($q -> param); + } + else { + # UTF-8 is (probably) correct, + # other encodings we don't know and fail + return unless $code =~ /^\303\277/; + } -# ==================================================== -# Initialisierung -# ==================================================== + # remove the ÿ (encoded as UTF-8) from quotechars + $q -> param ($formdata -> {quoteChar} -> {name} => substr ($code, 2)); -BEGIN { - %subhash = (newThread => \&new_thread, - missingKey => \&missing_key, - unexpectedKey => \&unexpected_key, - unknownEncoding => \&unknown_encoding, - tooShort => \&too_short, - tooLong => \&too_long, - wrongMail => \&wrong_mail, - Occupied => \&occupied, - Dupe => \&dupe_posting, - noReply => \&no_reply, - gotReply => \&got_reply, - gotNew => \&got_new - ); - - # Die RFC-gerechte URL-Erkennung ist aus dem Forum - # (thx2Cheatah - wo auch immer er sie (in der Form) her hat :-) - my $lowalpha = '(?:[a-z])'; - my $hialpha = '(?:[A-Z])'; - my $alpha = "(?:$lowalpha|$hialpha)"; - my $digit = '(?:\d)'; - my $safe = '(?:[$_.+-])'; - my $hex = '(?:[\dA-Fa-f])'; - my $escape = "(?:%$hex$hex)"; - my $digits = '(?:\d+)'; - my $alphadigit = "(?:$alpha|\\d)"; - - # URL schemeparts for ip based protocols: - my $port = "(?:$digits)"; - my $hostnumber = "(?:$digits\\.$digits\\.$digits\\.$digits)"; - my $toplabel = "(?:(?:$alpha(?:$alphadigit|-)*$alphadigit)|$alpha)"; - my $domainlabel = "(?:(?:$alphadigit(?:$alphadigit|-)*$alphadigit)|$alphadigit)"; - my $hostname = "(?:(?:$domainlabel\\.)*$toplabel)"; - my $host = "(?:(?:$hostname)|(?:$hostnumber))"; - my $hostport = "(?:(?:$host)(?::$port)?)"; - - my $httpuchar = "(?:(?:$alpha|$digit|$safe|(?:[!*\',]))|$escape)"; - my $hsegment = "(?:(?:$httpuchar|[;:\@&=~])*)"; - my $search = "(?:(?:$httpuchar|[;:\@&=~])*)"; - my $hpath = "(?:$hsegment(?:/$hsegment)*)"; - - # das alles ergibt eine gueltige URL :-) - $httpurl = "^(?:https?://$hostport(?:/$hpath(?:\\?$search)?)?)\$"; + # ok, params now should be UTF-8 encoded + 1; } -# ==================================================== -# end of fo_posting.pl -# ==================================================== \ No newline at end of file +# +# +### end of fo_posting.pl ####################################################### \ No newline at end of file -- 2.34.1