]> git.treefish.org Git - fex.git/blob - cgi-bin/pup
241e2d35b351e64660759be0b9e36d09679e2d05
[fex.git] / cgi-bin / pup
1 #!/usr/bin/perl -wT
2
3 # F*EX CGI for public upload
4 #
5 # Author: Ulli Horlacher <framstag@rus.uni-stuttgart.de>
6 #
7
8 BEGIN { ($ENV{PERLINIT}||'') =~ /(.+)/s and eval $1 }
9
10 # add fex lib
11 (our $FEXLIB) = $ENV{FEXLIB} =~ /(.+)/;
12 die "$0: no $FEXLIB\n" unless -d $FEXLIB;
13
14 $| = 1;
15
16 our $error = 'F*EX public upload ERROR';
17 our $head = "$ENV{SERVER_NAME} F*EX public upload";
18 our $locale = '';
19
20 # import from fex.ph
21 our (@public_recipients);
22
23 # import from fex.pp
24 our ($FEXHOME);
25
26 # load common code, local config: $FEXLIB/fex.ph
27 require "$FEXLIB/fex.pp" or die "$0: cannot load $FEXLIB/fex.pp - $!\n";
28
29 $from = $to = '';
30
31 chdir $spooldir or http_die("$spooldir - $!\n");
32
33 &check_maint;
34
35 my $qs = $ENV{QUERY_STRING};
36 (my $multi) = $qs =~ s/(^|&)multi//;
37   
38 # parse HTTP QUERY_STRING (parameter=value pairs)
39 if ($qs) {
40   foreach (split '&',$qs) {
41     if (s/^(\w+)=//) {
42       my $x = $1;
43       # decode URL-encoding
44       s/%([a-f0-9]{2})/chr(hex($1))/gie;
45       if (/([<>\'\`\"\000-\040])/) {
46         http_die(sprintf(
47           "\"&#%s;\" is not allowed in URL parameter",
48           ord($1)
49         ));
50       }
51       setparam($x,$_); 
52     }
53   }
54 }
55
56 # parse HTTP POST body
57 if ($ENV{REQUEST_METHOD} eq 'POST') {
58   if ($ENV{CONTENT_TYPE} =~ /boundary=\"?([\w\-\+\/_]+)/) {
59     $boundary = $1;
60   } else {
61     http_die("malformed HTTP POST (no boundary found)");
62   }
63
64   binmode(STDIN,':raw');
65     
66   READPOST: while (&nvt_read) {
67     if (/^Content-Disposition:\s*form-data;\s*name="([a-z]\w*)"/i) {
68       my $x = $1;
69       while (&nvt_read) { last if /^\s*$/ }
70       &nvt_read;
71       setparam($x,$_);
72       NEXTPART: while (&nvt_read) {
73         last READPOST if /^--\Q$boundary--/;
74         last NEXTPART if /^--\Q$boundary/;
75       }
76     }
77   }
78 }
79
80 unless (@public_recipients) {
81   html_error($error,"No public recipients defined by administrator");
82 }
83
84 if ($to and not grep /^\Q$to\E$/i,@public_recipients) {
85   html_error($error,"$to is not a public recipient");
86 }
87
88 if ($to and $from and checkaddress($from)) {
89   nvt_print(
90     "HTTP/1.1 302 Found",
91     "Location: $ENV{PROTO}://$ENV{HTTP_HOST}/fup?from=$from&to=$to&id=PUBLIC",
92     'Content-Length: 0',
93     ""
94   );
95   exec($FEXHOME.'/bin/fexsrv') if $ENV{KEEP_ALIVE};
96   exit;
97 }
98   
99 http_header('200 ok');
100 print html_header($head);
101
102 my @locales;
103 foreach my $locale (glob "$FEXHOME/locale/*") {
104   if (-f "$locale/cgi-bin/pup") {
105     my $langf = "$locale/lang.html";
106     $locale =~ s:.*/::;
107     $lang = $locale;
108     if (open $langf,'<',$langf) {
109       $lang = getline($langf);
110       close $langf;
111     }
112     push @locales,"<a href=\"/pup?to=$to&locale=$locale\">$lang</a>";
113   }
114 }
115 print "<h3>@locales</h3>\n" if @locales > 1;
116
117
118 pq(qq(
119   '<form name="upload"'
120   '      action="/fup"'
121   '      method="post"'
122   '      accept-charset="UTF-8"'
123   '      enctype="multipart/form-data">'
124   '  <input type="hidden" name="id" value="PUBLIC">'
125   '  <input type="hidden" name="autodelete" value="no">'
126   '  <table border="1">'
127 ));
128
129 if ($from) {
130   pq(qq(
131     '    <tr><td>your e-mail address:<td>$from</tr>'
132     '    <input type="hidden" name="from" value="$from">'
133   ));
134 } else {
135   pq(qq(
136     '    <tr><td>your e-mail address:<td><input type="text" name="from" size="80"></tr>'
137   ));
138 }
139
140 if ($to) {
141   pq(qq(
142     '    <tr><td>recipient:<td>$to</tr>'
143     '    <input type="hidden" name="to" value="$to">'
144   ));
145 } else {
146   if ($multi) {
147     foreach my $pr (@public_recipients) {
148       push @pr,qq(<input type="checkbox" name="to" value="$pr">)
149                ."<code>$pr</code><br>";
150     }
151     pq(qq(
152       '    <tr><td>recipient:<td>@pr</tr>'
153     ));
154   } else {
155     foreach my $pr (@public_recipients) {
156       push @pr,"<option>$pr</option>";
157     }
158     pq(qq(
159       '    <tr><td>recipient:<td><select name="to" size="1">@pr</select></tr>'
160     ));
161   }
162 }
163
164 pq(qq(
165   '  </table>'
166   '  <p>'
167   '  <input type="submit" name="continue" value="continue">'
168   '</form>'
169 ));
170
171
172 # set parameter variables
173 sub setparam {
174   my ($v,$vv) = @_;
175   
176   $v = uc(despace($v));
177   if ($v eq 'LOCALE' and $vv =~ /^(\w+)$/) {
178     $locale = $1;
179   } elsif ($v eq 'FROM') { 
180     $from = normalize_email($vv);
181   } elsif ($v eq 'TO') {
182     $to = normalize_email($vv);
183   }
184 }