project/captive/DriverSurvey.pm

   1 # $Id$
   2 # Captive project DriverSurvey page Perl template.
   3 # Copyright (C) 2005 Jan Kratochvil <project-www.jankratochvil.net@jankratochvil.net>
   4 #
   5 # This program is free software; you can redistribute it and/or modify
   6 # it under the terms of the GNU General Public License as published by
   7 # the Free Software Foundation; exactly version 2 of June 1991 is required
   8 #
   9 # This program is distributed in the hope that it will be useful,
  10 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 # GNU General Public License for more details.
  13 #
  14 # You should have received a copy of the GNU General Public License
  15 # along with this program; if not, write to the Free Software
  16 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  17
  18
  19 package project::captive::DriverSurvey;
  20 require 5.6.0;  # at least 'use warnings;' but we need some 5.6.0+ modules anyway
  21 our $VERSION=do { my @r=(q$Revision$=~/\d+/g); sprintf "%d.".("%03d"x$#r),@r; };
  22 our $CVS_ID=q$Id$;
  23 use strict;
  24 use warnings;
  25
  26 use My::Web;
  27 use Apache2::Cookie;
  28 require Time::Piece::ISO;
  29 use Carp qw(confess cluck);
  30
  31
  32 our $HTML_TEST_QUERY_STRING="captive-static-1.1.6-0.i386.rpm";
  33
  34
  35 # It will not return the new cookie if you set one!
  36 sub cookie(;$)
  37 {
  38 my($val)=@_;
  39
  40         my $trash;      # For {"headers_in"} stability.
  41         $trash=$W->{"headers_in"}{"Cookie"};
  42         $trash=$W->{"headers_in"}{"Cookie2"};
  43         my $jar=Apache2::Cookie::Jar->new($W->{"r"});
  44         my $name=__PACKAGE__;
  45         if (defined $val) {
  46                 my $cookie=Apache2::Cookie->new($W->{"r"},
  47                                 "name"   =>$name,
  48                                 "value"  =>$val,
  49                                 "expires"=>"+3M",
  50                                 "domain" =>$W->{"web_hostname"},
  51                                 # No __PACKAGE__ as it needs to be retrieved also from: /project/captive/Index.pm
  52                                 "path"   =>"/project/captive/",
  53                                 "secure" =>0,
  54                                 # Do not: # Prevent: Can't bake2 a Netscape cookie
  55                                 #         "version"=>1,
  56                                 # as RFCed "Cookie2" somehow does not work and even nobody uses it.
  57                                 );
  58                 # Do not: $cookie->bake2($W->{"r"});
  59                 # as RFCed "Cookie2" somehow does not work and even nobody uses it.
  60                 $cookie->bake($W->{"r"});
  61                 }
  62         # Somehow it may croak on error parsing the cookie headers or whatever.
  63         return eval { $jar->cookies($name) };
  64 }
  65
  66
  67 my $COLS=50;
  68
  69 sub nameval($)
  70 {
  71 my($name)=@_;
  72
  73         my $val=$W->{"args"}{$name};
  74         return 'name="'.$name.'"'.(!defined $val ? "" : ' value="'.escapeHTML($val).'"');
  75 }
  76
  77 sub textarea($$;$)
  78 {
  79 my($name,$rows,$attr)=@_;
  80
  81         return <<"HERE";
  82         <textarea rows="$rows" cols="$COLS" name="$name"@{[
  83                 !$attr ? '' : ' '.$attr
  84                 ]}>@{[ escapeHTML($W->{"args"}{$name}||"") ]}</textarea>
  85 HERE
  86 }
  87
  88 sub radio($$;$)
  89 {
  90 my($name,$value,$attr)=@_;
  91
  92         return <<"HERE";
  93         <input type="radio" name="$name" value="$value"@{[
  94                 ($W->{"args"}{$name}||"") ne $value ? '' : ' checked="checked"'
  95                 ]}@{[
  96                 !$attr ? '' : ' '.$attr
  97                 ]} />
  98 HERE
  99 }
 100
 101 sub store()
 102 {
 103         my $data="";
 104         $data.=<<"HERE";
 105 stamp: @{[ Time::Piece::ISO::gmtime()."+00:00" ]}
 106 HERE
 107         for my $key (qw(
 108                 User-Agent
 109                 Referer
 110                 _remote_ip
 111                 X-Forwarded-For
 112                 )) {
 113                 next if !defined (my $val=$W->{"headers_in"}{$key});
 114                 $data.=<<"HERE"
 115 headers_in::$key=$val
 116 HERE
 117                 }
 118         $data.="\n";
 119         for my $key (sort keys(%{$W->{"args"}})) {
 120                 next if $key eq "file";
 121                 next if $key eq "submit";
 122                 my $val=$W->{"args"}{$key};
 123                 next if !defined $val;
 124                 next if $val eq "";
 125                 $data.=<<"HERE";
 126 $key:
 127 $val
 128
 129 HERE
 130                 }
 131         $data.=("-" x 78)."\n\n";
 132
 133         my $filename=">>".path_abs_disk("./DriverSurvey.out");
 134         local *F;
 135         open F,$filename or confess "open \"$filename\": $!";
 136         print F $data or confess "write \"$filename\": $!";
 137         close F or confess "close \"$filename\": $!";
 138 }
 139
 140 sub submit()
 141 {
 142         return "Please check the appropriate leftmost checkmark."
 143                         if !$W->{"args"}{"kind"};
 144         store();
 145         # It works as &Apache2::Cookie::bake uses &err_headers_out - it is a redirect (not 200 OK).
 146         cookie(1);
 147         My::Web->http_moved("./");
 148 }
 149
 150 sub handler
 151 {
 152 My::Web->init(
 153                 "title"=>'Captive NTFS - Linux Drivers Availability Survey',
 154                 "js_push"=>"./DriverSurvey.js",
 155                 "args_check"=>{
 156                         "file"=>'^[^/]*$',
 157                         },
 158                 "args_persistent"=>{map(($_=>1),qw(
 159                         file
 160                         ))},
 161                 "css_push"=>"./Lib.css",
 162                 "heading"=>0,
 163                 "footer"=>0,
 164                 "no_job"=>1,
 165                 "http_safe"=>0,
 166                 );
 167
 168 # Workaround persistence of 'empty' argument - omit it instead.
 169 do { $$_=undef() if !$$_; } for \$W->{"args"}{"file"};
 170
 171 my $error=submit() if $W->{"args"}{"submit"};
 172
 173 # At least after &submit !
 174 My::Web->heading();
 175
 176
 177 my $PRODUCTS_MAX=5;
 178
 179
 180 print <<"HERE";
 181
 182 <h1>Linux Drivers Availability</h1>
 183 HERE
 184
 185 if (!$error) {
 186         print <<"HERE";
 187 <p>Please take a minute before downloading Captive NTFS to fill in this survey
 188 for the possibility to extend Captive for free support of other MS-Windows drivers
 189 (besides the current file system drivers). The original MS-Windows installation
 190 (<b>ntoskrnl.exe</b>) would not even be needed in such case.</p>
 191 HERE
 192         }
 193 else {
 194         print <<"HERE";
 195 <p align="center" class="error" id="error">$error</p>
 196 HERE
 197         }
 198
 199 print <<"HERE";
 200 <form action="DriverSurvey.pm" @{[ form_method "post" ]} onsubmit="return DriverSurvey_validate(this);">
 201 @{[ input_hidden_persistents() ]}
 202 <table border="0" width="80%" class="margin-center padded">
 203         <tr><td><table border="1" width="100%" class="padded">
 204                 <tr><td>
 205                         <p>@{[ radio "kind","owned"    ]}&nbsp;I would like such MS-Windows drivers interface
 206                                         - I have a hardware device missing Linux support.</p>
 207                         <p>@{[ radio "kind","wannabuy" ]}&nbsp;I would like to buy a hardware device
 208                                         but so far I could not as it is not Linux compatible.</p>
 209
 210                         <table border="0" class="vtop">
 211                                 <tr><td style="font-size: larger;" align="center" colspan="2">Incompatible Hardware Details</td></tr>
 212 HERE
 213 for my $producti (0..$PRODUCTS_MAX-1) {
 214 print <<"HERE";
 215                                 <tr id="product${producti}_row0"><td align="center">Product #@{[ 1+$producti ]}</td></tr>
 216                                 <tr id="product${producti}_row1">
 217                                         <td>Vendor (if known) and product name</td>
 218                                         <td><input type="text" size="$COLS" @{[ nameval "product${producti}_name" ]} /></td>
 219                                 </tr>
 220                                 <tr id="product${producti}_row2">
 221                                         <td>Product webpage URL (if known)</td>
 222                                         <td><input type="text" size="$COLS" @{[ nameval "product${producti}_url"  ]} /></td>
 223                                 </tr>
 224 HERE
 225         }
 226 # Just a protection for non-CSS non-JS browsers to no longer display the button:
 227 if (!$W->{"args"}{"productnext"}) {
 228         print <<"HERE";
 229                                 <tr style="display: none;" id="productnext_row0"><td colspan="2">&nbsp;</td></tr>
 230                                 <tr style="display: none;" id="productnext_row1"><td colspan="2" align="center">
 231                                         <input type="submit" name="productnext" value="More Devices &gt;&gt;&gt;"
 232                                                         onclick="return Survey_productnext(this);" />
 233                                 </td></tr>
 234 HERE
 235         }
 236 print <<"HERE";
 237                                 <!-- cooperate -->
 238                                 <tr><td colspan="2">&nbsp;</td></tr>
 239                                 <tr>
 240                                         <td rowspan="4">Would you like to cooperate on the driver testing?</td>
 241                                         <td>
 242                                         @{[ radio "coop","yes"   ]}&nbsp;Yes, I want to test a snapshot of the driver right now.
 243                                         </td>
 244                                 </tr>
 245                                 <tr><td>
 246                                         @{[ radio "coop","buy"   ]}&nbsp;Yes but only if the driver somehow works
 247                                                         to buy the device first.
 248                                 </td></tr>
 249                                 <tr><td>
 250                                         @{[ radio "coop","no"    ]}&nbsp;No, I do not own the device
 251                                                         or I do not want to test it.
 252                                 </td></tr>
 253                                 <tr><td>
 254                                         @{[ radio "coop","other",'id="coop_other_radio"' ]}&nbsp;Other answer:<br />
 255                                         @{[ textarea "coop_other_textarea",2,q{onkeypress="click_on('coop_other_radio');"} ]}
 256                                 </td></tr>
 257
 258                         </table>
 259                 </td></tr>
 260
 261                 <tr><td>@{[ radio "kind","oss" ]}&nbsp;I know a specific hardware (either mine or just seen)
 262                                 is not compatible but I do not want to use MS-Windows drivers in Linux.
 263
 264                         <p>What are the more specific reasons? Are you aware the drivers in Linux are
 265                         in many times just reverse engineered out of their MS-Windows counterparts?</p>
 266
 267                         @{[ textarea "kind_oss",3 ]}
 268                 </td></tr>
 269
 270                 <tr><td>@{[ radio "kind","working"  ]}&nbsp;All my hardware is working perfectly in Linux.</td></tr>
 271
 272                 <tr><td>@{[ radio "kind","answered" ]}&nbsp;I already answered this survey before.</td></tr>
 273         </table></td></tr>
 274
 275         <tr><td>Your e-mail; optional but appreciated: <input type="text" size="30" @{[ nameval "email" ]} /></td></tr>
 276
 277         <tr><td>Comments<br />
 278                 @{[ textarea "comment",3 ]}
 279         </td></tr>
 280 HERE
 281 if ($error) {
 282         print <<"HERE";
 283         <tr><td align="center" class="error">$error</td></tr>
 284 HERE
 285         }
 286 print <<"HERE";
 287         <tr><td align="center">
 288                 <input type="submit" name="submit" value="@{[
 289                                 $W->{"args"}{"file"}
 290                                                 ? "Submit and download ".escapeHTML($W->{"args"}{"file"})
 291                                                 : "Submit the survey"
 292                                 ]}" />
 293         </td></tr>
 294 </table>
 295 </form>
 296
 297 <p>Direct e-mail address: @{[ a_href 'mailto:driversurvey@jankratochvil.net' ]}</p>
 298
 299 HERE
 300
 301
 302 exit;
 303 }
 304 1;