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-30                          #
   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   ###################################################
 139   # now we know, we've got a filled out form
 140   # we do the following steps to check it:
 141   #
 142   # 1st: create a reverse Hash (CGI-key - identifier)
 143   # 2nd: did we get _all_ must-keys?
 144   #      check whether reply or new message request
 145   # 3rd: did we get too many keys?
 146   # 4th: do _all_ requested values accord to
 147   #      expectations?
 148   #      fetch the "missing" keys
 149   #
 150
 151   # 1
 152   #
 153   my %name = map {($formdata -> {$_} -> {name} => $_)} keys %$formdata;
 154
 155   # 2
 156   #
 157   $self -> {response} -> {reply} = $got_keys {$formdata -> {followUp} -> {name}}? 1 : 0;
 158   $self -> {response} -> {new}   = not $self -> {response} -> {reply};
 159
 160   # define the fetch array (values to fetch from parent message)
 161   #
 162   $self -> {fetch} = [];
 163
 164   for ( @{$formmust -> {$self -> {response} -> {reply}?'reply':'new'}} ) {
 165
 166     unless ($got_keys {$formdata -> {$_} -> {name}}) {
 167
 168       # only miss the key unless we're able to fetch it from parent posting
 169       #
 170       unless (
 171            $self -> {response} -> {new}
 172         or $formdata -> {$name {$_}} -> {errorType} eq 'fetch') {
 173
 174         $self -> {error} = {spec => 'missing_key'};
 175         return;
 176       }
 177       else {
 178         # keep in mind to fetch the value later
 179         #
 180         push @{$self -> {fetch}} => $name {$_};
 181       }
 182     }
 183   }
 184
 185   # 3
 186   #
 187   for ($self -> {cgi_object} -> param) {
 188     unless (exists ($name {$_})) {
 189       $self -> {error} = {
 190         spec => 'unexpected_key',
 191         desc => $name{$_}
 192       };
 193       return;
 194     }
 195   }
 196
 197   # 4
 198   #
 199   unless ($self -> decode_param) {
 200     $self -> {error} = {spec => 'unknown_encoding'};
 201     return;
 202   };
 203
 204   # I'm lazy - I know...
 205   my $q = $self -> {cgi_object};
 206
 207   if ($self -> {response} -> {reply}) {
 208
 209     # get the parent-identifiers if we got a reply
 210     #
 211     my ($ftid, $fmid) = split /;/ => $q -> param ($formdata -> {followUp} -> {name}) => 2;
 212
 213     unless ($ftid =~ /\d+/ and $fmid =~ /\d+/) {
 214       $self -> {error} = {spec => 'unknown_followup'};
 215       return;
 216     }
 217     $self -> {fup_tid} = $ftid;
 218     $self -> {fup_mid} = $fmid;
 219
 220     # now fetching the missing keys
 221     # if it fails, they're too short, too... ;)
 222     #
 223     $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 to normal spaces
 233     $q -> param ($_ => $val);  # write it back
 234
 235     # too long?
 236     #
 237     if (length $val > $formdata -> {$name {$_}} -> {maxlength}) {
 238       $self -> {error} = {
 239         spec => 'too_long',
 240         desc => $name{$_}
 241       };
 242       return;
 243     }
 244
 245     # too short?
 246     # (only check if there's defined a minimum length)
 247     #
 248     if (exists ($formdata -> {$name {$_}} -> {minlength})) {
 249
 250       # kill the whitespaces to get only the visible characters...
 251       #
 252       (my $val_ww = $val) =~ s/\s+//g;
 253
 254       if (length $val_ww < $formdata -> {$name {$_}} -> {minlength}) {
 255         $self -> {error} = {
 256           spec => 'too_short',
 257           desc => $name{$_}
 258         };
 259         return;
 260       }
 261     }
 262
 263 #    return 'wrongMail' if ($formdata -> {$name{$_}} -> {type} eq 'email' and length ($dparam{$_}) and not is_mail_address ($dparam{$_}));
 264   }
 265
 266   # ok, looks good.
 267   1;
 268 }
 269
 270 #  delete $dparam {$formdata -> {posterURL} -> {name}}
 271 #    unless ($dparam {$formdata -> {posterURL} -> {name}} =~ /$httpurl/);
 272 #
 273 #  delete $dparam {$formdata -> {posterImage} -> {name}}
 274 #    unless ($dparam {$formdata -> {posterImage} -> {name}} =~ /$httpurl/);
 275
 276 ### sub fetch ##################################################################
 277 #
 278 # fetch "missing" keys from parent posting
 279 #
 280 sub fetch {
 281   my $self = shift;
 282   my $q = $self -> {cgi_object};
 283   my $formdata = $self -> {conf} -> {form_data};
 284
 285   if (@{$self -> {fetch}}) {
 286     my $filename = $self -> {conf} -> {message_path}.'t'.$self -> {fup_tid}.'.xml';
 287
 288     if (lock_file ($filename)) {
 289       my $xml = parse_xml_file ($filename);
 290       violent_unlock_file($filename) unless unlock_file ($filename);
 291
 292       if ($xml) {
 293         my $mnode = get_message_node ($xml, 't'.$self -> {fup_tid}, 'm'.$self -> {fup_mid});
 294         if ($mnode) {
 295           my $header = get_message_header ($mnode);
 296
 297           $q -> param ($formdata -> {$_} -> {name} => $header -> {$formdata -> {$_} -> {header}})
 298             for (@{$self -> {fetch}});
 299         }
 300       }
 301     }
 302   }
 303
 304   # fetching failed:
 305   # fillout the values with an empty string
 306   #
 307   $q -> param ($formdata -> {$_} -> {name} => '')
 308     for (@{$self -> {fetch}});
 309 }
 310
 311 ### sub decode_param ###########################################################
 312 #
 313 # convert submitted form data into UTF-8
 314 # unless it's not encoded yet
 315 #
 316 # Return: Status Code (Bool)
 317 #         false if unknown encoding (like UTF-7 for instance)
 318 #
 319 sub decode_param {
 320   my $self = shift;
 321
 322   my $q = $self -> {cgi_object};
 323   my $formdata = $self -> {conf} -> {form_data};
 324
 325   my $code = $q -> param ($formdata -> {quoteChar} -> {name});
 326   my @array;
 327
 328   # Latin 1 (we hope so - there's no real way to find out :-( )
 329   if ($code =~ /^\377/) {
 330     $q -> param ($_ => map {toUTF8($_)} $q -> param ($_)) for ($q -> param);
 331   }
 332   else {
 333     # UTF-8 is (probably) correct,
 334     # other encodings we don't know and fail
 335     return unless $code =~ /^\303\277/;
 336   }
 337
 338   # remove the &#255; (encoded as UTF-8) from quotechars
 339   $q -> param ($formdata -> {quoteChar} -> {name} => substr ($code, 2));
 340
 341   # ok, params now should be UTF-8 encoded
 342   1;
 343 }
 344
 345 #
 346 #
 347 ### end of fo_posting.pl #######################################################