# $Id$
# Captive project DriverSurvey page Perl template.
# Copyright (C) 2005 Jan Kratochvil <project-www.jankratochvil.net@jankratochvil.net>
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; exactly version 2 of June 1991 is required
# 
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
# 
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA


package project::captive::DriverSurvey;
require 5.6.0;	# at least 'use warnings;' but we need some 5.6.0+ modules anyway
our $VERSION=do { my @r=(q$Revision$=~/\d+/g); sprintf "%d.".("%03d"x$#r),@r; };
our $CVS_ID=q$Id$;
use strict;
use warnings;

use My::Web;
use Apache2::Cookie;
require Time::Piece::ISO;
use Carp qw(confess cluck);


our $HTML_TEST_QUERY_STRING="captive-static-1.1.6-0.i386.rpm";


# It will not return the new cookie if you set one!
sub cookie(;$)
{
my($val)=@_;

	my $trash;	# For {"headers_in"} stability.
	$trash=$W->{"headers_in"}{"Cookie"};
	$trash=$W->{"headers_in"}{"Cookie2"};
	my $jar=Apache2::Cookie::Jar->new($W->{"r"});
	my $name=__PACKAGE__;
	if (defined $val) {
		my $cookie=Apache2::Cookie->new($W->{"r"},
				"name"   =>$name,
				"value"  =>$val,
				"expires"=>"+3M", 
				"domain" =>$W->{"web_hostname"},
				# No __PACKAGE__ as it needs to be retrieved also from: /project/captive/Index.pm
				"path"   =>"/project/captive/",
				"secure" =>0,
				# Do not: # Prevent: Can't bake2 a Netscape cookie
				#         "version"=>1,
				# as RFCed "Cookie2" somehow does not work and even nobody uses it.
				); 
		# Do not: $cookie->bake2($W->{"r"});
		# as RFCed "Cookie2" somehow does not work and even nobody uses it.
		$cookie->bake($W->{"r"});
		}
	# Somehow it may croak on error parsing the cookie headers or whatever.
	return eval { $jar->cookies($name) };
}


my $COLS=50;

sub nameval($)
{
my($name)=@_;

	my $val=$W->{"args"}{$name};
	return 'name="'.$name.'"'.(!defined $val ? "" : ' value="'.escapeHTML($val).'"');
}

sub textarea($$;$)
{
my($name,$rows,$attr)=@_;

	return <<"HERE";
	<textarea rows="$rows" cols="$COLS" name="$name"@{[
		!$attr ? '' : ' '.$attr
		]}>@{[ escapeHTML($W->{"args"}{$name}||"") ]}</textarea>
HERE
}

sub radio($$;$)
{
my($name,$value,$attr)=@_;

	return <<"HERE";
	<input type="radio" name="$name" value="$value"@{[
		($W->{"args"}{$name}||"") ne $value ? '' : ' checked="checked"'
		]}@{[
		!$attr ? '' : ' '.$attr
		]} />
HERE
}

sub store()
{
	my $data="";
	$data.=<<"HERE";
stamp: @{[ Time::Piece::ISO::gmtime()."+00:00" ]}
HERE
	for my $key (qw(
		User-Agent
		Referer
		_remote_ip
		X-Forwarded-For
		)) {
		next if !defined (my $val=$W->{"headers_in"}{$key});
		$data.=<<"HERE"
headers_in::$key=$val
HERE
		}
	$data.="\n";
	for my $key (sort keys(%{$W->{"args"}})) {
		next if $key eq "file";
		next if $key eq "submit";
		my $val=$W->{"args"}{$key};
		next if !defined $val;
		next if $val eq "";
		$data.=<<"HERE";
$key:
$val

HERE
		}
	$data.=("-" x 78)."\n\n";

	my $filename=">>".path_abs_disk("./DriverSurvey.out");
	local *F;
	open F,$filename or confess "open \"$filename\": $!";
	print F $data or confess "write \"$filename\": $!";
	close F or confess "close \"$filename\": $!";
}

sub submit()
{
	return "Please check the appropriate leftmost checkmark."
			if !$W->{"args"}{"kind"};
	store();
	# It works as &Apache2::Cookie::bake uses &err_headers_out - it is a redirect (not 200 OK).
	cookie(1);
	My::Web->http_moved("./");
}

sub handler
{
My::Web->init(
		"title"=>'Captive NTFS - Linux Drivers Availability Survey',
		"js_push"=>"./DriverSurvey.js",
		"args_check"=>{
			"file"=>'^[^/]*$',
			},
		"args_persistent"=>{map(($_=>1),qw(
			file
			))},
		"css_push"=>"./Lib.css",
		"heading"=>0,
		"footer"=>0,
		"no_job"=>1,
		"http_safe"=>0,
		);

# Workaround persistence of 'empty' argument - omit it instead.
do { $$_=undef() if !$$_; } for \$W->{"args"}{"file"};

my $error=submit() if $W->{"args"}{"submit"};

# At least after &submit !
My::Web->heading();


my $PRODUCTS_MAX=5;


print <<"HERE";

<h1>Linux Drivers Availability</h1>
HERE

if (!$error) {
	print <<"HERE";
<p>Please take a minute before downloading Captive NTFS to fill in this survey
for the possibility to extend Captive for free support of other MS-Windows drivers
(besides the current file system drivers). The original MS-Windows installation
(<b>ntoskrnl.exe</b>) would not even be needed in such case.</p>
HERE
	}
else {
	print <<"HERE";
<p align="center" class="error" id="error">$error</p>
HERE
	}

print <<"HERE";
<form action="DriverSurvey.pm" @{[ form_method "post" ]} onsubmit="return DriverSurvey_validate(this);">
@{[ input_hidden_persistents() ]}
<table border="0" width="80%" class="margin-center padded">
	<tr><td><table border="1" width="100%" class="padded">
		<tr><td>
			<p>@{[ radio "kind","owned"    ]}&nbsp;I would like such MS-Windows drivers interface
					- I have a hardware device missing Linux support.</p>
			<p>@{[ radio "kind","wannabuy" ]}&nbsp;I would like to buy a hardware device
					but so far I could not as it is not Linux compatible.</p>

			<table border="0" class="vtop">
				<tr><td style="font-size: larger;" align="center" colspan="2">Incompatible Hardware Details</td></tr>
HERE
for my $producti (0..$PRODUCTS_MAX-1) {
print <<"HERE";
				<tr id="product${producti}_row0"><td align="center">Product #@{[ 1+$producti ]}</td></tr>
				<tr id="product${producti}_row1">
					<td>Vendor (if known) and product name</td>
					<td><input type="text" size="$COLS" @{[ nameval "product${producti}_name" ]} /></td>
				</tr>
				<tr id="product${producti}_row2">
					<td>Product webpage URL (if known)</td>
					<td><input type="text" size="$COLS" @{[ nameval "product${producti}_url"  ]} /></td>
				</tr>
HERE
	}
# Just a protection for non-CSS non-JS browsers to no longer display the button:
if (!$W->{"args"}{"productnext"}) {
	print <<"HERE";
				<tr style="display: none;" id="productnext_row0"><td colspan="2">&nbsp;</td></tr>
				<tr style="display: none;" id="productnext_row1"><td colspan="2" align="center">
					<input type="submit" name="productnext" value="More Devices &gt;&gt;&gt;"
							onclick="return Survey_productnext(this);" />
				</td></tr>
HERE
	}
print <<"HERE";
				<!-- cooperate -->
				<tr><td colspan="2">&nbsp;</td></tr>
				<tr>
					<td rowspan="4">Would you like to cooperate on the driver testing?</td>
					<td>
					@{[ radio "coop","yes"   ]}&nbsp;Yes, I want to test a snapshot of the driver right now.
					</td>
				</tr>
				<tr><td>
					@{[ radio "coop","buy"   ]}&nbsp;Yes but only if the driver somehow works
							to buy the device first.
				</td></tr>
				<tr><td>
					@{[ radio "coop","no"    ]}&nbsp;No, I do not own the device
							or I do not want to test it.
				</td></tr>
				<tr><td>
					@{[ radio "coop","other",'id="coop_other_radio"' ]}&nbsp;Other answer:<br />
					@{[ textarea "coop_other_textarea",2,q{onkeypress="click_on('coop_other_radio');"} ]}
				</td></tr>

			</table>
		</td></tr>

		<tr><td>@{[ radio "kind","oss" ]}&nbsp;I know a specific hardware (either mine or just seen)
				is not compatible but I do not want to use MS-Windows drivers in Linux.

			<p>What are the more specific reasons? Are you aware the drivers in Linux are
			in many times just reverse engineered out of their MS-Windows counterparts?</p>

			@{[ textarea "kind_oss",3 ]}
		</td></tr>

		<tr><td>@{[ radio "kind","working"  ]}&nbsp;All my hardware is working perfectly in Linux.</td></tr>

		<tr><td>@{[ radio "kind","answered" ]}&nbsp;I already answered this survey before.</td></tr>
	</table></td></tr>

	<tr><td>Your e-mail; optional but appreciated: <input type="text" size="30" @{[ nameval "email" ]} /></td></tr>

	<tr><td>Comments<br />
		@{[ textarea "comment",3 ]}
	</td></tr>
HERE
if ($error) {
	print <<"HERE";
	<tr><td align="center" class="error">$error</td></tr>
HERE
	}
print <<"HERE";
	<tr><td align="center">
		<input type="submit" name="submit" value="@{[
				$W->{"args"}{"file"}
						? "Submit and download ".escapeHTML($W->{"args"}{"file"})
						: "Submit the survey"
				]}" />
	</td></tr>
</table>
</form>

<p>Direct e-mail address: @{[ a_href 'mailto:driversurvey@jankratochvil.net' ]}</p>

HERE


exit;
}
1;