selfforum-cgi/user/fo_posting.pl

   1 #!/usr/bin/perl -wT
   2
   3 ################################################################################
   4 #                                                                              #
   5 # File:        user/fo_posting.pl                                              #
   6 #                                                                              #
   7 # Authors:     André Malo <nd@o3media.de>, 2001-03-31                          #
   8 #                                                                              #
   9 # Description: Accept new postings, display "Neue Nachricht" page              #
  10 #                                                                              #
  11 # not ready, be patient please                                                 #
  12 #                                                                              #
  13 ################################################################################
  14
  15 use strict;
  16 use vars qw($Bin $Shared $Script);
  17
  18 # locate the script
  19 BEGIN {
  20   my $null = $0; $null =~ s/\\/\//g; # for win :-(
  21   ($Bin)    = ($null =~ /^(.*)\/.*$/)? $1 : '.';
  22   $Shared   = "$Bin/../shared";
  23   ($Script) = ($null =~ /^.*\/(.*)$/)? $1 : $null;
  24 }
  25
  26 use lib "$Shared";
  27 #use CGI::Carp qw(fatalsToBrowser);
  28
  29 use Conf;
  30 use Encode::Plain; $Encode::Plain::utf8 = 1;
  31 use Encode::Posting;
  32 use Id;
  33 use Lock qw(:ALL);
  34 use CheckRFC;
  35 use Posting::_lib qw(get_all_threads get_message_node get_message_header hr_time parse_xml_file);
  36 use Posting::Write;
  37 use Template;
  38 use Template::Posting;
  39
  40 use CGI;
  41 use XML::DOM;
  42
  43 # load script configuration and admin default conf.
  44 my $conf         = read_script_conf ($Bin, $Shared, $Script);
  45 my $adminDefault = read_admin_conf ($conf -> {files} -> {adminDefault});
  46
  47 # Initializing the request
  48 my $response = new Posting::Response ($conf, $adminDefault);
  49
  50 # fetch and parse the cgi-params
  51 $response -> parse_cgi;
  52
  53
  54 ################################################################################
  55 ### Posting::Response ##########################################################
  56 package Posting::Response;
  57
  58 ### sub new ####################################################################
  59 #
  60 # initialising the Posting::Response object
  61 # check parameters and fill in object properties
  62 #
  63 sub new {
  64   my ($class, $conf, $adminDefault) = @_;
  65
  66   my $sp = $conf -> {show} -> {Posting};
  67
  68   my $self = {
  69        conf => {
  70          original => $conf,
  71          admin    => $adminDefault,
  72
  73          message_path    => $conf -> {files} -> {messagePath},
  74          forum_file_name => $conf -> {files} -> {forum},
  75
  76          show_posting    => $sp,
  77          assign          => $sp -> {assign},
  78          form_must       => $sp -> {form} -> {must},
  79          form_data       => $sp -> {form} -> {data},
  80          form_action     => $sp -> {form} -> {action},
  81        },
  82
  83        template => new Template $sp -> {templateFile}
  84      };
  85
  86   bless $self, $class;
  87 }
  88
  89 ### sub parse_cgi ##############################################################
  90 #
  91 # fetch and decode cgi-parameters,
  92 # find out the kind of response requested by the user (new message, reply)
  93 #
  94 # Return: Status Code (Bool)
  95 #         try out the error method, if false
  96 #
  97 sub parse_cgi {
  98   my $self = shift;
  99
 100   # create the CGI object
 101   my $q = new CGI;
 102   $self -> {cgi_object} = $q;
 103
 104   # check the params
 105   return unless $self -> check_cgi;
 106 }
 107
 108 ### sub check_cgi ##############################################################
 109 #
 110 # cgi params are like raw eggs...
 111 #
 112 # Return: Status Code (Bool)
 113 #         creates content for the error method if anything fails
 114 #
 115 sub check_cgi {
 116   my $self = shift;
 117
 118   # find out the count of the submitted keys and the keys themselves
 119   #
 120   my %got_keys     = map {($_ => 1)} $self -> {cgi_object} -> param;
 121   my $cnt_got_keys = keys %got_keys;
 122   my $formdata = $self -> {conf} -> {form_data};
 123   my $formmust = $self -> {conf} -> {form_must};
 124
 125   # user requested the 'new thread' page
 126   # (no params or only the user-ID has been submitted)
 127   #
 128   if ($cnt_got_keys == 0 or (
 129         exists ($formdata -> {userID})
 130         and $cnt_got_keys == 1
 131         and $got_keys{$formdata -> {userID} -> {name}}
 132         )
 133      ) {
 134     $self -> {response} = {new_thread => 1};
 135     return 1;
 136   }
 137
 138   # now we know, we've got a filled out form
 139   # we do the following steps to check it:
 140   #
 141   # 1st: create a reverse Hash (CGI-key - identifier)
 142   # 2nd: did we get _all_ must-keys?
 143   #      check whether reply or new message request
 144   # 3rd: did we get too many keys?
 145   # 4th: do _all_ submitted values accord to
 146   #      our expectations?
 147   #      fetch the "missing" keys
 148   #
 149
 150   # 1
 151   #
 152   my %name = map {($formdata -> {$_} -> {name} => $_)} keys %$formdata;
 153
 154   # 2
 155   #
 156   $self -> {response} -> {reply} = $got_keys {$formdata -> {followUp} -> {name}}? 1 : 0;
 157   $self -> {response} -> {new}   = not $self -> {response} -> {reply};
 158
 159   # define the fetch array (values to fetch from parent message)
 160   #
 161   $self -> {fetch} = [];
 162
 163   for ( @{$formmust -> {$self -> {response} -> {reply}?'reply':'new'}} ) {
 164
 165     unless ($got_keys {$formdata -> {$_} -> {name}}) {
 166
 167       # only miss the key unless we're able to fetch it from parent posting
 168       #
 169       unless (
 170            $self -> {response} -> {new}
 171         or $formdata -> {$name {$_}} -> {errorType} eq 'fetch') {
 172
 173         $self -> {error} = {spec => 'missing_key'};
 174         return;
 175       }
 176       else {
 177         # keep in mind to fetch the value later
 178         #
 179         push @{$self -> {fetch}} => $name {$_};
 180       }
 181     }
 182   }
 183
 184   # 3
 185   #
 186   for ($self -> {cgi_object} -> param) {
 187     unless (exists ($name {$_})) {
 188       $self -> {error} = {
 189         spec => 'unexpected_key',
 190         desc => $name{$_}
 191       };
 192       return;
 193     }
 194   }
 195
 196   # 4
 197   #
 198   unless ($self -> decode_param) {
 199     $self -> {error} = {spec => 'unknown_encoding'};
 200     return;
 201   };
 202
 203   # I'm lazy - I know...
 204   my $q = $self -> {cgi_object};
 205
 206   if ($self -> {response} -> {reply}) {
 207
 208     # get the parent-identifiers if we got a reply
 209     #
 210     my ($ftid, $fmid) = split /;/ => $q -> param ($formdata -> {followUp} -> {name}) => 2;
 211
 212     unless ($ftid =~ /\d+/ and $fmid =~ /\d+/) {
 213       $self -> {error} = {spec => 'unknown_followup'};
 214       return;
 215     }
 216     $self -> {fup_tid} = $ftid;
 217     $self -> {fup_mid} = $fmid;
 218
 219     # fetch the missing keys
 220     # if it fails, they're too short, too... ;)
 221     #
 222     $self -> fetch;
 223     $got_keys{$_}=1 for (@{$self -> {fetch}});
 224   }
 225
 226   # now we can check on length, type etc.
 227   #
 228   for (keys %got_keys) {
 229
 230     my $val = $q -> param ($_);
 231
 232     $val =~ s/\302\240/ /g;           # convert nbsp (UTF-8 encoded) into normal spaces
 233     $val =~ s/\015\012|\015|\012/ /g  # convert \n into spaces unless it's a multiline field
 234       unless (
 235         exists ($formdata -> {$name {$_}} -> {type})
 236         and $formdata -> {$name {$_}} -> {type} eq 'multiline-text'
 237       );
 238
 239     $q -> param ($_ => $val);  # write it back
 240
 241     # too long?
 242     #
 243     if (length $val > $formdata -> {$name {$_}} -> {maxlength}) {
 244       $self -> {error} = {
 245         spec => 'too_long',
 246         desc => $name{$_}
 247       };
 248       return;
 249     }
 250
 251     # too short?
 252     # (only check if there's defined a minimum length)
 253     #
 254     if (exists ($formdata -> {$name {$_}} -> {minlength})) {
 255
 256       # kill the whitespaces to get only the visible characters...
 257       #
 258       (my $val_ww = $val) =~ s/\s+//g;
 259
 260       if (length $val_ww < $formdata -> {$name {$_}} -> {minlength}) {
 261         $self -> {error} = {
 262           spec => 'too_short',
 263           desc => $name{$_}
 264         };
 265         return;
 266       }
 267     }
 268
 269     # check the values on expected kinds of content
 270     # (email, http-url, url)
 271     #
 272     if (exists ($formdata -> {$name {$_}} -> {type}) and length $val) {
 273       if ($formdata -> {$name {$_}} -> {type} eq 'email' and not is_email $val) {
 274         $self -> {error} = {
 275           spec => 'wrong_mail',
 276           desc => $name{$_}
 277         };
 278         return;
 279       }
 280
 281       elsif ($formdata -> {$name {$_}} -> {type} eq 'http-url' and not is_URL $val => 'http') {
 282         $self -> {error} = {
 283           spec => 'wrong_http_url',
 284           desc => $name{$_}
 285         };
 286         return;
 287       }
 288
 289       elsif ($formdata -> {$name {$_}} -> {type} eq 'url' and not is_URL $val => ':ALL') {
 290         $self -> {error} = {
 291           spec => 'wrong_url',
 292           desc => $name{$_}
 293         };
 294         return;
 295       }
 296     }
 297   }
 298
 299   # ok, looks good.
 300   1;
 301 }
 302
 303 ### sub fetch ##################################################################
 304 #
 305 # fetch "missing" keys from parent posting
 306 #
 307 sub fetch {
 308   my $self = shift;
 309   my $q = $self -> {cgi_object};
 310   my $formdata = $self -> {conf} -> {form_data};
 311
 312   if (@{$self -> {fetch}}) {
 313     my $filename = $self -> {conf} -> {message_path}.'t'.$self -> {fup_tid}.'.xml';
 314
 315     if (lock_file ($filename)) {
 316       my $xml = parse_xml_file ($filename);
 317       violent_unlock_file($filename) unless unlock_file ($filename);
 318
 319       if ($xml) {
 320         my $mnode = get_message_node ($xml, 't'.$self -> {fup_tid}, 'm'.$self -> {fup_mid});
 321         if ($mnode) {
 322           my $header = get_message_header ($mnode);
 323
 324           $q -> param ($formdata -> {$_} -> {name} => $header -> {$formdata -> {$_} -> {header}})
 325             for (@{$self -> {fetch}});
 326         }
 327       }
 328     }
 329   }
 330
 331   # fetching failed:
 332   # fillout the values with an empty string
 333   #
 334   $q -> param ($formdata -> {$_} -> {name} => '')
 335     for (@{$self -> {fetch}});
 336 }
 337
 338 ### sub decode_param ###########################################################
 339 #
 340 # convert submitted form data into UTF-8
 341 # unless it's not encoded yet
 342 #
 343 # Return: Status Code (Bool)
 344 #         false if unknown encoding (like UTF-7 for instance)
 345 #
 346 sub decode_param {
 347   my $self = shift;
 348
 349   my $q = $self -> {cgi_object};
 350   my $formdata = $self -> {conf} -> {form_data};
 351
 352   my $code = $q -> param ($formdata -> {quoteChar} -> {name});
 353   my @array;
 354
 355   # Latin 1 (we hope so - there's no real way to find out :-( )
 356   if ($code =~ /^\377/) {
 357     $q -> param ($_ => map {toUTF8($_)} $q -> param ($_)) for ($q -> param);
 358   }
 359   else {
 360     # UTF-8 is (probably) correct,
 361     # other encodings we don't know and fail
 362     return unless $code =~ /^\303\277/;
 363   }
 364
 365   # remove the &#255; (encoded as UTF-8) from quotechars
 366   $q -> param ($formdata -> {quoteChar} -> {name} => substr ($code, 2));
 367
 368   # ok, params now should be UTF-8 encoded
 369   1;
 370 }
 371
 372 #
 373 #
 374 ### end of fo_posting.pl #######################################################