view release on metacpan or  search on metacpan

lib/DiaColloDB/WWW/CGI.pm  view on Meta::CPAN

		     request_uri => undef,
		     request_query => undef,
		     http_referer => undef,
		     http_host    => undef,
		     server_addr  => undef,
		     server_port  => undef,
		     ##
		     ##-- template toolkit stuff
		     ttk_package => (ref($that)||$that),
		     ttk_vars    => {},			##-- template vars
		     ttk_config  => {ENCODING=>'utf8'},	##-- options for Template->new()
		     ttk_process => {binmode=>':utf8'},	##-- options for Template->process()
		     ttk_dir     => abs_path(dirname($0)),
		     ttk_key     => undef,		##-- current template basename
		     ttk_rawkeys => {			##-- pseudo-set of raw keys
				     profile=>1,
				    },
		     ##
		     ##-- File::ShareDir stuff (fallbacks for ttk_dir)
		     ttk_sharedir => File::ShareDir::dist_dir("DiaColloDB-WWW")."/htdocs",
		     ##
		     ##-- user args
		     @_,
		    }, ref($that)||$that);

  ##-- CGI package
  if ($dbcgi->{cgipkg}) {
    eval "use $dbcgi->{cgipkg} qw(:standard :cgi-lib);";
    $dbcgi->logconfess("new(): could not use {cgipkg} $dbcgi->{cgipkg}: $@") if ($@);
  }

  ##-- environment defaults
  $dbcgi->_getenv();

  return $dbcgi;
}

## @keys = $dbcgi->_param()
## $val  = $dbcgi->_param($name)
sub _param {
  my $dbcgi = shift;
  return $dbcgi->cgi('param',@_);
}

## $dbcgi = $dbcgi->_reset()
##  + resets CGI environment
sub _reset {
  my $dbcgi = shift;
  delete @$dbcgi{(qw(vars),
		qw(remote_addr remote_user),
		qw(request_method request_uri request_query),
		qw(http_referer http_host server_addr server_port),
	       )};
  return $dbcgi;
}

## $dbcgi = $dbcgi->_getenv()
sub _getenv {
  my $dbcgi = shift;
  $dbcgi->{remote_addr} = ($ENV{REMOTE_ADDR}||'0.0.0.0');
  $dbcgi->{remote_user} = ($ENV{REMOTE_USER} || getpwuid($>));
  $dbcgi->{request_method} = ($ENV{REQUEST_METHOD}||'GET');
  $dbcgi->{request_uri} = ($ENV{REQUEST_URI} || $0);
  $dbcgi->{request_query} = $ENV{QUERY_STRING};
  $dbcgi->{http_referer} = $ENV{HTTP_REFERER};
  $dbcgi->{http_host} = $ENV{HTTP_HOST};
  $dbcgi->{server_addr} = $ENV{SERVER_ADDR};
  $dbcgi->{server_port} = $ENV{SERVER_PORT};
  return $dbcgi;
}

## $dbcgi = $dbcgi->fromRequest($httpRequest,$csock)
##  + sets up $dbcgi from an HTTP::Request object
sub fromRequest {
  my ($dbcgi,$hreq,$csock) = @_;

  ##-- setup pseudo-environment
  my $uri = $hreq->uri;
  my @path = grep {$_ ne ''} $uri->path_segments;
  $dbcgi->{prog}        = $path[$#path] || 'index';
  $dbcgi->{remote_addr} = $ENV{REMOTE_ADDR} = $csock ? $csock->peerhost : '0.0.0.0';
  $dbcgi->{remote_port} = $ENV{REMOTE_PORT} = $csock ? $csock->peerport : '0';
  $dbcgi->{remote_user} = $ENV{REMOTE_USER} = '';
  $dbcgi->{request_method} = $ENV{REQUEST_METHOD} = $hreq->method;
  $dbcgi->{request_uri}   = $ENV{REQUEST_URI} = $uri->as_string;
  $dbcgi->{request_query} = $ENV{REQUEST_QUERY} = $uri->query;
  $dbcgi->{http_referer}  = $ENV{HTTP_REFERER} = $hreq->referer;
  $dbcgi->{http_host}   = $ENV{HTTP_HOST} = $uri->host || $csock->sockhost;
  $dbcgi->{server_addr} = $ENV{SERVER_ADDR} = $csock ? $csock->sockaddr : '0.0.0.0';
  $dbcgi->{server_port} = $ENV{SERVER_PORT} = $csock ? $csock->sockport : '0';

  ##-- setup variables
  my %vars = $uri->query_form;
  my $addVars = sub {
    my $add = shift;
    foreach (grep {defined $add->{$_}} keys %$add) {
      if (!exists($vars{$_})) {
	$vars{$_} = $add->{$_};
      } else {
	$vars{$_} = [ $vars{$_} ] if (!ref($vars{$_}));
	push(@{$vars{$_}}, ref($add->{$_}) ? @{$add->{$_}} : $add->{$_});
      }
    }
  };
  if ($hreq->method eq 'POST') {
    if ($hreq->content_type eq 'application/x-www-form-urlencoded') {
      ##-- POST: x-www-form-urlencoded
      $addVars->( {URI->new('?'.$hreq->content)->query_form} );
    }
    elsif ($hreq->content_type eq 'multipart/form-data') {
      ##-- POST: multipart/form-data: parse by hand
      foreach my $part ($hreq->parts) {
	my $pdis = $part->header('Content-Disposition');
	if ($pdis =~ /^form-data\b/) {
	  ##-- POST: multipart/form-data: part: form-data; name="PARAMNAME"
	  if ($pdis =~ /\bname=[\"\']?([\w\-\.\,\+]*)[\'\"]?/) {
	    $addVars->({ $1 => $part->content });
	    next;
	  }
	}
	##-- POST: multipart/form-data: part: anything other than 'form-data; name="PARAMNAME"'