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                 )) {
 112                 next if !defined (my $val=$W->{"headers_in"}{$key});
 113                 $data.=<<"HERE"
 114 headers_in::$key=$val
 115 HERE
 116                 }
 117         $data.="\n";
 118         for my $key (sort keys(%{$W->{"args"}})) {
 119                 next if $key eq "file";
 120                 next if $key eq "submit";
 121                 my $val=$W->{"args"}{$key};
 122                 next if !defined $val;
 123                 next if $val eq "";
 124                 $data.=<<"HERE";
 125 $key:
 126 $val
 127
 128 HERE
 129                 }
 130         $data.=("-" x 78)."\n\n";
 131
 132         my $filename=">>".path_abs_disk("./DriverSurvey.out");
 133         local *F;
 134         open F,$filename or confess "open \"$filename\": $!";
 135         print F $data or confess "write \"$filename\": $!";
 136         close F or confess "close \"$filename\": $!";
 137 }
 138
 139 sub submit()
 140 {
 141         return "Please check the appropriate leftmost checkmark."
 142                         if !$W->{"args"}{"kind"};
 143         store();
 144         # It works as &Apache2::Cookie::bake uses &err_headers_out - it is a redirect (not 200 OK).
 145         cookie(1);
 146         My::Web->http_moved("./");
 147 }
 148
 149 sub handler
 150 {
 151 My::Web->init(
 152                 "title"=>'Captive NTFS - Linux Drivers Availability Survey',
 153                 "js_push"=>"./DriverSurvey.js",
 154                 "args_check"=>{
 155                         "file"=>'^[^/]*$',
 156                         },
 157                 "args_persistent"=>{map(($_=>1),qw(
 158                         file
 159                         ))},
 160                 "css_push"=>"./Lib.css",
 161                 "heading"=>0,
 162                 "footer"=>0,
 163                 "no_job"=>1,
 164                 "http_safe"=>0,
 165                 );
 166
 167 # Workaround persistence of 'empty' argument - omit it instead.
 168 do { $$_=undef() if !$$_; } for \$W->{"args"}{"file"};
 169
 170 my $error=submit() if $W->{"args"}{"submit"};
 171
 172 # At least after &submit !
 173 My::Web->heading();
 174
 175
 176 my $PRODUCTS_MAX=5;
 177
 178
 179 print <<"HERE";
 180
 181 <h1>Linux Drivers Availability</h1>
 182 HERE
 183
 184 if (!$error) {
 185         print <<"HERE";
 186 <p>Please take a minute before downloading Captive NTFS to fill in this survey
 187 for the possibility to extend Captive for free support of other MS-Windows drivers
 188 (besides the current file system drivers). The original MS-Windows installation
 189 (<b>ntoskrnl.exe</b>) would not even be needed in such case.</p>
 190 HERE
 191         }
 192 else {
 193         print <<"HERE";
 194 <p align="center" class="error" id="error">$error</p>
 195 HERE
 196         }
 197
 198 print <<"HERE";
 199 <form action="DriverSurvey.pm" @{[ form_method "post" ]} onsubmit="return DriverSurvey_validate(this);">
 200 @{[ input_hidden_persistents() ]}
 201 <table border="0" width="80%" class="margin-center padded">
 202         <tr><td><table border="1" width="100%" class="padded">
 203                 <tr><td>
 204                         <p>@{[ radio "kind","owned"    ]}&nbsp;I would like such MS-Windows drivers interface
 205                                         - I have a hardware device missing Linux support.</p>
 206                         <p>@{[ radio "kind","wannabuy" ]}&nbsp;I would like to buy a hardware device
 207                                         but so far I could not as it is not Linux compatible.</p>
 208
 209                         <table border="0" class="vtop">
 210                                 <tr><td style="font-size: larger;" align="center" colspan="2">Incompatible Hardware Details</td></tr>
 211 HERE
 212 for my $producti (0..$PRODUCTS_MAX-1) {
 213 print <<"HERE";
 214                                 <tr id="product${producti}_row0"><td align="center">Product #@{[ 1+$producti ]}</td></tr>
 215                                 <tr id="product${producti}_row1">
 216                                         <td>Vendor (if known) and product name</td>
 217                                         <td><input type="text" size="$COLS" @{[ nameval "product${producti}_name" ]} /></td>
 218                                 </tr>
 219                                 <tr id="product${producti}_row2">
 220                                         <td>Product webpage URL (if known)</td>
 221                                         <td><input type="text" size="$COLS" @{[ nameval "product${producti}_url"  ]} /></td>
 222                                 </tr>
 223 HERE
 224         }
 225 # Just a protection for non-CSS non-JS browsers to no longer display the button:
 226 if (!$W->{"args"}{"productnext"}) {
 227         print <<"HERE";
 228                                 <tr style="display: none;" id="productnext_row0"><td colspan="2">&nbsp;</td></tr>
 229                                 <tr style="display: none;" id="productnext_row1"><td colspan="2" align="center">
 230                                         <input type="submit" name="productnext" value="More Devices &gt;&gt;&gt;"
 231                                                         onclick="return Survey_productnext(this);" />
 232                                 </td></tr>
 233 HERE
 234         }
 235 print <<"HERE";
 236                                 <!-- cooperate -->
 237                                 <tr><td colspan="2">&nbsp;</td></tr>
 238                                 <tr>
 239                                         <td rowspan="4">Would you like to cooperate on the driver testing?</td>
 240                                         <td>
 241                                         @{[ radio "coop","yes"   ]}&nbsp;Yes, I want to test a snapshot of the driver right now.
 242                                         </td>
 243                                 </tr>
 244                                 <tr><td>
 245                                         @{[ radio "coop","buy"   ]}&nbsp;Yes but only if the driver somehow works
 246                                                         to buy the device first.
 247                                 </td></tr>
 248                                 <tr><td>
 249                                         @{[ radio "coop","no"    ]}&nbsp;No, I do not own the device
 250                                                         or I do not want to test it.
 251                                 </td></tr>
 252                                 <tr><td>
 253                                         @{[ radio "coop","other",'id="coop_other_radio"' ]}&nbsp;Other answer:<br />
 254                                         @{[ textarea "coop_other_textarea",2,q{onkeypress="click_on('coop_other_radio');"} ]}
 255                                 </td></tr>
 256
 257                         </table>
 258                 </td></tr>
 259
 260                 <tr><td>@{[ radio "kind","oss" ]}&nbsp;I know a specific hardware (either mine or just seen)
 261                                 is not compatible but I do not want to use MS-Windows drivers in Linux.
 262
 263                         <p>What are the more specific reasons? Are you aware the drivers in Linux are
 264                         in many times just reverse engineered out of their MS-Windows counterparts?</p>
 265
 266                         @{[ textarea "kind_oss",3 ]}
 267                 </td></tr>
 268
 269                 <tr><td>@{[ radio "kind","working"  ]}&nbsp;All my hardware is working perfectly in Linux.</td></tr>
 270
 271                 <tr><td>@{[ radio "kind","answered" ]}&nbsp;I already answered this survey before.</td></tr>
 272         </table></td></tr>
 273
 274         <tr><td>Your e-mail; optional but appreciated: <input type="text" size="30" @{[ nameval "email" ]} /></td></tr>
 275
 276         <tr><td>Comments<br />
 277                 @{[ textarea "comment",3 ]}
 278         </td></tr>
 279 HERE
 280 if ($error) {
 281         print <<"HERE";
 282         <tr><td align="center" class="error">$error</td></tr>
 283 HERE
 284         }
 285 print <<"HERE";
 286         <tr><td align="center">
 287                 <input type="submit" name="submit" value="@{[
 288                                 $W->{"args"}{"file"}
 289                                                 ? "Submit and download ".escapeHTML($W->{"args"}{"file"})
 290                                                 : "Submit the survey"
 291                                 ]}" />
 292         </td></tr>
 293 </table>
 294 </form>
 295
 296 <p>Direct e-mail address: @{[ a_href 'mailto:driversurvey@jankratochvil.net' ]}</p>
 297
 298 HERE
 299
 300
 301 exit;
 302 }
 303 1;