]> git.p6c8.net - selfforum.git/blob - selfforum-cgi/user/fo_posting.pl
forum.dtd is now up to date.
[selfforum.git] / selfforum-cgi / user / fo_posting.pl
1 #!/usr/bin/perl
2
3 ################################################################################
4 # #
5 # File: user/fo_posting.pl #
6 # #
7 # Authors: André Malo <nd@o3media.de>, 2001-01-25 #
8 # #
9 # Description: Accept new postings, display "Neue Nachricht" page #
10 # #
11 ################################################################################
12
13 use strict;
14 use vars qw($Bin $Shared $Script %subhash $httpurl $flocked);
15
16 BEGIN {
17 ($Bin) = ($0 =~ /^(.*)\/.*$/)? $1 : '.';
18 $Shared = "$Bin/../shared";
19 ($Script) = ($0 =~ /^.*\/(.*)$/)? $1 : $0;}
20
21 use CGI::Carp qw(fatalsToBrowser);
22
23 use lib "$Shared";
24 use Conf;
25 use Encode::Plain; $Encode::Plain::utf8 = 1;
26 use Encode::Posting;
27 use Id;
28 use Lock qw(:ALL);
29 use Mail;
30 use Posting::_lib qw(get_all_threads get_message_node get_message_header hr_time);
31 use Posting::Write;
32 use Template;
33 use Template::Posting;
34
35 use CGI qw(param header);
36 use XML::DOM;
37
38 print header (-type => 'text/html');
39
40 our $conf = read_script_conf ($Bin, $Shared, $Script);
41
42 our $show_posting = $conf -> {show} -> {Posting};
43 our $assign = $show_posting -> {assign};
44 our $formmust = $show_posting -> {form} -> {must};
45 our $formdata = $show_posting -> {form} -> {data};
46 our $formact = $show_posting -> {form} -> {action};
47 our $template = new Template "$Bin/".$show_posting -> {templateFile};
48 our $pars = {};
49 our ($failed, %dparam, $threads, $last_thread, $last_message, $ftid, $fmid, $flocked);
50
51 sub forum_filename () {$conf -> {wwwRoot} . $conf -> {files} -> {forum};}
52 sub message_path () {$conf -> {wwwRoot} . $conf -> {files} -> {messagePath};}
53
54 ################################
55
56 # Formfelder ausfuellen (Namen)
57 for (qw(posterBody uniqueID followUp quoteChar userID posterName posterEmail posterCategory posterSubject posterURL posterImage)) {
58 $pars -> {$formdata -> {$_} -> {assign} -> {name}} = plain($formdata -> {$_} -> {name});}
59
60 my $checked = &check_param;
61
62 unless (exists ($subhash {$checked})) {
63 &print_fatal ($assign -> {unknownError});}
64
65 else {
66 unless ($checked eq 'newThread') {
67 $checked = &check_reply_dupe() || $checked;}
68
69 unless (exists ($subhash {$checked})) {
70 &print_fatal ($assign -> {unknownError});}
71 else {
72 &{$subhash {$checked}};}
73
74 if ($flocked) {
75 violent_unlock_file (forum_filename) unless (write_unlock_file (forum_filename));}}
76
77 # ====================================================
78 # end of main / Funktionen
79 # ====================================================
80
81
82 ### check_reply_dupe () ########################################################
83 #
84 # Reply moeglich? Doppelposting?
85 #
86 # Params: -none-
87 # Return: Dupe check result
88 # 'Dupe' - Posting is a dupe
89 # Nothing - ok.
90 #
91 sub check_reply_dupe () {
92 my $stat;
93
94 unless ($stat = write_lock_file (forum_filename)) {
95 if ($stat == 0) {
96 # ueberlastet oder so
97 violent_unlock_file (forum_filename);
98 return 'Occupied';
99 } else {
100 return 'masterLock';
101 }
102 } else {
103 my ($i, %msg, %unids);
104
105 $flocked = 1;
106
107 ($threads, $last_thread, $last_message, my $unids) = get_all_threads (forum_filename, 1, 0);
108 ($ftid,$fmid) = split /;/,$dparam{$formdata -> {followUp} -> {name}},2;
109
110 # Thread existiert nicht
111 if (exists($dparam{$formdata -> {followUp} -> {name}})) {
112 return 'noReply' unless (exists($threads -> {$ftid}));
113
114 # nur nicht geloeschte Messages beachten
115 for ($i=0; $i < @{$threads -> {$ftid}}; $i++) {
116 if ($threads -> {$ftid} -> [$i] -> {deleted}) {
117 $+=$threads -> {$ftid} -> [$i] -> {answers};}
118
119 else {
120 $msg{$threads -> {$ftid} -> [$i] -> {mid}}=$i;}}
121
122 # Message existiert nicht
123 if (exists($dparam{$formdata -> {followUp} -> {name}})) {
124 return 'noReply' unless (exists($msg{$fmid}));}
125
126 %unids = map {$_ => 1} @{$threads -> {$ftid} -> [$msg{$fmid}] -> {unids}};
127 } else {
128 %unids = map {$_ => 1} @$unids;
129 }
130
131 # jetzt endlich
132 return 'Dupe' if (exists ($unids{$dparam{$formdata -> {uniqueID} -> {name}}}));
133 }
134
135 return;
136 }
137
138 ################################
139 # sub got_new
140 #
141 # Eroeffnungsposting speichern
142 ################################
143
144 sub got_new () {
145
146 my $time = time;
147 my $pars = {author => $dparam {$formdata -> {posterName} -> {name}},
148 email => $dparam {$formdata -> {posterEmail} -> {name}},
149 category => $dparam {$formdata -> {posterCategory} -> {name}},
150 subject => $dparam {$formdata -> {posterSubject} -> {name}},
151 body => $dparam {$formdata -> {posterBody} -> {name}},
152 homepage => $dparam {$formdata -> {posterURL} -> {name}},
153 image => $dparam {$formdata -> {posterImage} -> {name}},
154 time => $time,
155 uniqueID => $dparam {$formdata -> {uniqueID} -> {name}},
156 ip => $ENV{REMOTE_ADDR},
157 forumFile => forum_filename,
158 messagePath => message_path,
159 lastThread => $last_thread,
160 lastMessage => $last_message,
161 parsedThreads => $threads,
162 dtd => 'forum.dtd',
163 quoteChars => toUTF8('»» '),
164 messages => $conf -> {template} -> {messages}};
165
166 my ($stat, $xml, $mid) = write_posting ($pars);
167 violent_unlock_file (forum_filename) unless (write_unlock_file (forum_filename));
168 $flocked = undef;
169
170 if ($stat) {
171 print "Och noe...: $stat";}
172
173 else {
174 my $thx = $show_posting -> {thanx};
175
176 print ${$template -> scrap ($assign -> {docThx},
177 {$thx -> {author} => plain ($dparam {$formdata -> {posterName} -> {name}}),
178 $thx -> {email} => plain ($dparam {$formdata -> {posterEmail} -> {name}}),
179 $thx -> {time} => plain (hr_time($time)),
180 $thx -> {body} => message_as_HTML ($xml, $template,
181 {posting => $mid,
182 assign => $assign}),
183 $thx -> {category} => plain ($dparam {$formdata -> {posterCategory} -> {name}}),
184 $thx -> {home} => plain ($dparam {$formdata -> {posterURL} -> {name}}),
185 $thx -> {image} => plain ($dparam {$formdata -> {posterImage} -> {name}}),
186 $thx -> {subject} => plain ($dparam {$formdata -> {posterSubject} -> {name}})})};
187 }
188 return;
189 }
190
191 ################################
192 # sub got_reply
193 #
194 # Antwortposting speichern
195 ################################
196
197 sub got_reply () {
198 my $stat;
199
200 my $time = time;
201 my $pars = {author => $dparam {$formdata -> {posterName} -> {name}},
202 email => $dparam {$formdata -> {posterEmail} -> {name}},
203 category => $dparam {$formdata -> {posterCategory} -> {name}},
204 subject => $dparam {$formdata -> {posterSubject} -> {name}},
205 body => $dparam {$formdata -> {posterBody} -> {name}},
206 homepage => $dparam {$formdata -> {posterURL} -> {name}},
207 image => $dparam {$formdata -> {posterImage} -> {name}},
208 time => $time,
209 uniqueID => $dparam {$formdata -> {uniqueID} -> {name}},
210 ip => $ENV{REMOTE_ADDR},
211 parentMessage => $fmid,
212 thread => $ftid,
213 forumFile => forum_filename,
214 messagePath => message_path,
215 lastThread => $last_thread,
216 lastMessage => $last_message,
217 parsedThreads => $threads,
218 dtd => 'forum.dtd',
219 quoteChars => toUTF8('»» '),
220 messages => $conf -> {template} -> {messages}};
221
222 ($stat, my $xml, my $mid) = write_posting ($pars);
223 violent_unlock_file (forum_filename) unless (write_unlock_file (forum_filename));
224 $flocked = undef;
225
226 if ($stat) {
227 print "Och noe...: $stat";}
228
229 else {
230 my $thx = $show_posting -> {thanx};
231
232 print ${$template -> scrap ($assign -> {docThx},
233 {$thx -> {author} => plain ($dparam {$formdata -> {posterName} -> {name}}),
234 $thx -> {email} => plain ($dparam {$formdata -> {posterEmail} -> {name}}),
235 $thx -> {time} => plain (hr_time($time)),
236 $thx -> {body} => message_as_HTML ($xml, $template,
237 {posting => $mid,
238 assign => $assign}),
239 $thx -> {category} => plain ($dparam {$formdata -> {posterCategory} -> {name}}),
240 $thx -> {home} => plain ($dparam {$formdata -> {posterURL} -> {name}}),
241 $thx -> {image} => plain ($dparam {$formdata -> {posterImage} -> {name}}),
242 $thx -> {subject} => plain ($dparam {$formdata -> {posterSubject} -> {name}})})};}
243 }
244
245 ################################
246 # sub new_thread
247 #
248 # HTML fuer Eroeffnungsposting
249 ################################
250
251 sub new_thread () {
252 my $list = [map {{$assign -> {optval} => plain($_)}} @{$formdata -> {posterCategory} -> {values}}];
253
254 # spaeter kommen noch userspezifische Daten dazu...
255 print ${$template -> scrap ($assign -> {docNew},
256 {$formdata->{uniqueID} ->{assign}->{value} => plain(unique_id),
257 $formdata->{quoteChar} ->{assign}->{value} => '&#255;'.plain(toUTF8('»» ')),
258 $formact->{post}->{assign} => $formact->{post}->{url},
259 $formdata->{posterCategory}->{assign}->{value} => $template->list ($assign -> {option}, $list)
260 },$pars)};
261 }
262
263 ################################
264 # diverse subs
265 #
266 # Fehlermeldungen
267 ################################
268
269 sub no_reply () {&print_fatal ($assign -> {noReply});}
270 sub dupe_posting () {&print_fatal ($assign -> {dupe});}
271 sub missing_key () {&print_fatal ($assign -> {wrongPar});}
272 sub unexpected_key () {&print_fatal ($assign -> {wrongPar});}
273 sub unknown_encoding () {&print_fatal ($assign -> {wrongCode});}
274 sub too_short () {
275 if ($formdata -> {$failed} -> {errorType} eq 'repeat') {
276 &print_error ($formdata -> {$failed} -> {assign} -> {tooShort},
277 $formdata -> {$failed} -> {minlength});}
278
279 else {
280 &print_fatal ($formdata -> {$failed} -> {assign} -> {tooShort});}
281 }
282
283 sub too_long () {
284 if ($formdata -> {$failed} -> {errorType} eq 'repeat') {
285 &print_error ($formdata -> {$failed} -> {assign} -> {tooLong},
286 $formdata -> {$failed} -> {maxlength});}
287
288 else {
289 &print_fatal ($formdata -> {$failed} -> {assign} -> {tooLong});}
290 }
291
292 sub wrong_mail () {print_error ($formdata -> {$failed} -> {assign} -> {wrong});}
293 sub occupied () {print_error ($assign -> {occupied});}
294
295 ################################
296 # sub print_fatal
297 #
298 # fatale Fehlerausgabe
299 ################################
300
301 sub print_fatal ($) {
302 print ${$template -> scrap ($assign -> {docFatal},
303 {$assign -> {errorMessage} => $template -> insert ($_[0])
304 },$pars)};
305 }
306
307 ################################
308 # sub print_error
309 #
310 # Fehlerausgabe, Moeglichkeit
311 # zur Korrektur
312 ################################
313
314 sub print_error ($;$) {
315 &fillin;
316 print ${$template -> scrap ($assign -> {docError},
317 {$assign -> {errorMessage} => $template -> insert ($_[0]),
318 $assign -> {charNum} => $_[1]
319 },$pars)};
320 }
321
322 ################################
323 # sub fetch_subject
324 #
325 # Subject und Category besorgen
326 # (wenn noch nicht vorhanden)
327 ################################
328
329 sub fetch_subject () {
330 unless (exists ($dparam{$formdata -> {posterCategory} -> {name}}) and
331 exists ($dparam{$formdata -> {posterSubject} -> {name}})) {
332
333 my $filename = message_path.'t'.$ftid.'.xml';
334
335 if (lock_file ($filename)) {
336 my $xml = new XML::DOM::Parser -> parsefile ($filename);
337 violent_unlock_file($filename) unless unlock_file ($filename);
338
339 my $mnode = get_message_node ($xml, "t$ftid", "m$fmid");
340 my $header = get_message_header ($mnode);
341
342 $dparam{$formdata -> {posterCategory} -> {name}} = $header -> {category};
343 $dparam{$formdata -> {posterSubject} -> {name}} = $header -> {subject};}}
344 }
345
346 ################################
347 # sub fillin
348 #
349 # Fuellen von $pars
350 # (bereits vorhandene Formdaten)
351 ################################
352
353 sub fillin () {
354 fetch_subject;
355
356 my $list = [map {{$assign -> {optval} => plain($_),
357 (($_ eq $dparam{$formdata -> {posterCategory} -> {name}})?($assign -> {optsel} => 1):())}}
358 @{$formdata -> {posterCategory} -> {values}}];
359
360 $pars -> {$formdata->{posterCategory}->{assign}->{value}} = $template->list ($assign -> {option}, $list);
361 $pars -> {$formact ->{post}->{assign}} = $formact->{post}->{url};
362 $pars -> {$formdata->{quoteChar}->{assign}->{value}} = '&#255;'.plain($dparam {$formdata -> {quoteChar} -> {name}} or '');
363
364 # Formfelder ausfuellen (Werte)
365 for (qw(uniqueID userID followUp posterName posterEmail posterSubject posterBody posterURL posterImage)) {
366 $pars -> {$formdata->{$_}->{assign}->{value}} = plain($dparam {$formdata -> {$_} -> {name}});}
367 }
368
369 ################################
370 # sub decode_param
371 #
372 # CGI-Parameter decodieren
373 # (rudimentaerer UTF8-support)
374 ################################
375
376 sub decode_param () {
377 my $code = param ($formdata -> {quoteChar} -> {name});
378 my @array;
379
380 # UTF-8 ([hoechst-]wahrscheinlich)
381 if ($code =~ /^\303\277/) {
382
383 foreach (param) {
384 @array=param ($_);
385
386 if (@array == 1) {
387 $dparam{$_} = $array[0];}
388
389 else {
390 $dparam{$_} = \@array;}}}
391
392 # Latin 1 (hoffentlich - eigentlich ist es gar keine Codierung...)
393 elsif ($code =~ /^\377/) {
394 foreach (param) {
395 @array=param ($_);
396
397 if (@array == 1) {
398 $dparam{$_} = toUTF8($array[0]);}
399
400 else {
401 $dparam{$_} = [map {toUTF8($_)} @array];}}}
402
403 # unbekannte Codierung
404 else {
405 return;}
406
407 # ersten beiden Zeichen der Quotechars loeschen (Indikator [&#255; (als UTF8)])
408 $dparam {$formdata -> {quoteChar} -> {name}} = ($dparam {$formdata -> {quoteChar} -> {name}} =~ /..(.*)/)[0];
409
410 delete $dparam {$formdata -> {posterURL} -> {name}}
411 unless ($dparam {$formdata -> {posterURL} -> {name}} =~ /$httpurl/);
412
413 delete $dparam {$formdata -> {posterImage} -> {name}}
414 unless ($dparam {$formdata -> {posterImage} -> {name}} =~ /$httpurl/);
415
416 # Codierung erkannt, alles klar
417 1;
418 }
419
420 ################################
421 # sub check_param
422 #
423 # CGI-Parameter pruefen
424 ################################
425
426 sub check_param () {
427 my %gotKeys = map {($_ => 1)} param;
428 my $numGotKeys = keys %gotKeys;
429
430 # Threaderoeffnung, Ersteingabe (leere Seite)
431 return 'newThread' if ($numGotKeys == 0 or
432 (($numGotKeys == 1) and ($gotKeys {$formdata -> {userID} -> {name}})));
433
434 # =======================================================
435 # ab hier steht fest, wir haben ein ausgefuelltes
436 # Formular bekommen
437 #
438 # 1. Umrechnungshash bauen (CGI-Key => Identifier)
439 # 2. alle must-keys vorhanden?
440 # 3. zuviele Parameter uebermittelt?
441 # 4. entsprechen die Daten den Anforderungen?
442 # (alle, nicht nur die must-Daten)
443
444 # 1
445 # ===
446 my %name = map {($formdata -> {$_} -> {name} => $_)} keys %$formdata;
447
448 # 2
449 # ===
450 $failed=1;
451 foreach (@{$formmust -> {$gotKeys {$formdata -> {followUp} -> {name}}?'reply':'new'}}) {
452 return 'missingKey' unless ($gotKeys {$formdata -> {$_} -> {name}});
453 }
454
455 # 3
456 # ===
457 foreach (param) {
458 $failed = $name {$_};
459 return 'unexpectedKey' unless (exists ($name {$_}));
460 }
461
462 # 4
463 # ===
464 return 'unknownEncoding' unless (decode_param);
465
466 foreach (keys %dparam) {
467 $failed = $name {$_};
468
469 return 'tooLong' if (length($dparam{$_}) > $formdata -> {$name {$_}} -> {maxlength});
470 return 'tooShort' if (@{[$dparam{$_} =~ /(\S)/g]} < $formdata -> {$name {$_}} -> {minlength});
471 return 'wrongMail' if ($formdata -> {$name{$_}} -> {type} eq 'email' and length ($dparam{$_}) and not is_mail_address ($dparam{$_}));
472 }
473
474 $failed=0;
475 return $gotKeys {$formdata -> {followUp} -> {name}}?'gotReply':'gotNew';
476 }
477
478 # ====================================================
479 # Initialisierung
480 # ====================================================
481
482 BEGIN {
483 %subhash = (newThread => \&new_thread,
484 missingKey => \&missing_key,
485 unexpectedKey => \&unexpected_key,
486 unknownEncoding => \&unknown_encoding,
487 tooShort => \&too_short,
488 tooLong => \&too_long,
489 wrongMail => \&wrong_mail,
490 Occupied => \&occupied,
491 Dupe => \&dupe_posting,
492 noReply => \&no_reply,
493 gotReply => \&got_reply,
494 gotNew => \&got_new
495 );
496
497 # Die RFC-gerechte URL-Erkennung ist aus dem Forum
498 # (thx2Cheatah - wo auch immer er sie (in der Form) her hat :-)
499 my $lowalpha = '(?:[a-z])';
500 my $hialpha = '(?:[A-Z])';
501 my $alpha = "(?:$lowalpha|$hialpha)";
502 my $digit = '(?:\d)';
503 my $safe = '(?:[$_.+-])';
504 my $hex = '(?:[\dA-Fa-f])';
505 my $escape = "(?:%$hex$hex)";
506 my $digits = '(?:\d+)';
507 my $alphadigit = "(?:$alpha|\\d)";
508
509 # URL schemeparts for ip based protocols:
510 my $port = "(?:$digits)";
511 my $hostnumber = "(?:$digits\\.$digits\\.$digits\\.$digits)";
512 my $toplabel = "(?:(?:$alpha(?:$alphadigit|-)*$alphadigit)|$alpha)";
513 my $domainlabel = "(?:(?:$alphadigit(?:$alphadigit|-)*$alphadigit)|$alphadigit)";
514 my $hostname = "(?:(?:$domainlabel\\.)*$toplabel)";
515 my $host = "(?:(?:$hostname)|(?:$hostnumber))";
516 my $hostport = "(?:(?:$host)(?::$port)?)";
517
518 my $httpuchar = "(?:(?:$alpha|$digit|$safe|(?:[!*\',]))|$escape)";
519 my $hsegment = "(?:(?:$httpuchar|[;:\@&=~])*)";
520 my $search = "(?:(?:$httpuchar|[;:\@&=~])*)";
521 my $hpath = "(?:$hsegment(?:/$hsegment)*)";
522
523 # das alles ergibt eine gueltige URL :-)
524 $httpurl = "^(?:https?://$hostport(?:/$hpath(?:\\?$search)?)?)\$";
525 }
526
527 # ====================================================
528 # end of fo_posting.pl
529 # ====================================================

patrick-canterino.de