#!/bin/sh
LC_ALL=C; export LC_ALL; exec perl -x -S "$0" "$@"	# -*- mode: cperl -*-
#! perl5.38кlocale¸ΤΤϵʤΤǤǤϤ

########################################################################
# CERN httpd°Ƥcgiparseޥɤδʰ	v1.01a
# ʪcgiparseޥɤĵǽΤݡȤƤʤΤ
# CGI¦type=fileȻꤵ줿硢åץɤ줿ե
# Фǽˤʤä
# âեΥåץɤ򤹤ˤformenctype="multipart/form-data"
#
# DACSȤեȥˤcgiparseȤǽΥޥɤޤޤƤ뤬
# ȤϻȤ䥪ץʤɤۤʤΤ

# ˡ: Τɤ餫
#	cgiparse -init
#	cgiparse -form [-prefix PREFIX] [-sep SEP] [-file VAR=FILE]
# Ȥˤ eval "`cgiparse -form`" Τ褦ˤ
# -file˥եμФ˼Ԥ֤1

use Getopt::Long;
use CGI;

sub usage{
	die <<'EOF';
Usage:	cgiparse -init
	cgiparse -form [-prefix PREFIX] [-sep SEP] [-file VAR=FILE]
EOF
}

my($prefix, $sep) = ('FORM_', ', ');
GetOptions(
	'init' => \$init,
	'form' => \$form,
	'file=s' => \%files,
	'prefix=s' => \$prefix,
	'sep=s' => \$sep,
) || &usage;
&usage if @ARGV || $init == $form; # ɤ餫λ

$ENV{'REQUEST_METHOD'} = ($ENV{'QUERY_STRING'} ne '') ? 'GET' : 'POST'
	if $ENV{'REQUEST_METHOD'} !~ /^(GET|POST)$/;

$q = new CGI;
if($init){
	my $qs = $q->query_string();
	$qs =~ s/'/'\\''/g;	# 'פϡ%27פˤʤΤ?
	print "QUERY_STRING='$qs'; export QUERY_STRING\n";
	exit;
} else {
	my $err = 0;
	for($q->param){ # ѿ̾ˤĤ
		# ѿ̾ȤƵʤΤñФ
		next if (my $vn = "$prefix$_") !~ /^(?!\d)\w+(?!\n)$/;

		# FORM_ѿ̾=͡פȤԤ
		my $v;
		{
			local $CGI::LIST_CONTEXT_WARN = 0;
			# $q->param($_)list contextǸƤ֤Ȥտ
			$v = join($sep, $q->param($_));
		}
		$v =~ s/'/'\\''/g;
		print "$vn='$v'\n";

		if(exists($files{$_})){	# եμФ
			my($fn, $f) = ($files{$_}, $q->upload($_));
			defined($f) || (
				warn("file $_ upload failed\n"),
				$v ne '' && ($err = 1), next
			);
			# $v(ե̤)ξ$err1ˤʤʤ
			# ΥΥå$v(ѿ)Ǥ뤳Ȥ
			# (cgiparseγ)뤳ȤǹԤ

			seek($f, 0, 0); # ǰΤ
			open(my $out, '>', $fn) ||
				(warn("$fn: $!\n"), $err = 1, next);
			my $s;
			print $out $s while(read($f, $s, 1024));
			close($out) ||
				(warn("$fn: $!\n"), $err = 1, next);
			# ¤$outϥ椨ư
		}
	}
	exit($err);
}
