The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
## @file
# (Enter your file info here)
#
# @copy 2007 MailerMailer LLC
# $Id: CGIadapter.pm 446 2008-05-07 17:45:44Z damjan $

## @class RWDE::Web::CGIadapter
# (Enter RWDE::Web::CGIadapter info here)
package RWDE::Web::CGIadapter;

use strict;
use warnings;

use Error qw(:try);
use RWDE::Exceptions;

use base qw(RWDE::Logging);

## @method object get_req()
# (Enter get_req info here)
# @return
sub get_req {
  my ($self, $params) = @_;

  return $self->{req};
}

## @method object is_https()
# (Enter is_https info here)
# @return
sub is_https {
  my ($self, $params) = @_;

  return ($self->get_req->protocol() eq 'https');
}

## @method void check_https()
# (Enter check_https info here)
sub check_https {
  my ($self, $params) = @_;

  unless ($self->is_https()) {
    throw RWDE::DevelException({ info => 'Attempt to access secure information on a non-ssl connection.' });
  }

  return ();
}

## @method object get_uri()
# (Enter get_uri info here)
# @return
sub get_uri {
  my ($self, $params) = @_;

  my $script_name = substr($self->get_req->script_name(), 1);

  #Get script returns the get part of the request if there is a // in it, we only want the script name
  my ($uri, $get_request) = split /\?/, $script_name;

  # get the uri requested
  return $uri;
}

## @method object get_url()
# (Enter get_url info here)
# @return
sub get_url {
  my ($self, $params) = @_;

  # get the uri requested
  return $self->get_req->url();
}

## @method object get_class()
# (Enter get_class info here)
# @return
sub get_class {
  my ($self, $params) = @_;

  my $uri = $self->get_uri();

  my $cpath = (split /\./, $uri)[0];    #the command path

  my @cparts = split /\//, $cpath;

  my $class = join('::', @cparts);

  $class = 'Command::' . $class;

  #replace dashes for underscores
  $class =~ s/-/_/g;

  #sanitize: remove everything that is not allowed in the package name
  # $class =~ /([a-zA-Z0-9_:]+)/;

  return ($class);
}

## @method object get_formdata()
# (Enter get_formdata info here)
# @return
sub get_formdata {
  my ($self, $params) = @_;

  my $formdata = {};

  foreach my $f ($self->get_req->param()) {

    #each param is an array, but there most likely is just one value
    my @ar = $self->get_req->param($f);

    #if this parameter had an array of values
    if (scalar @ar > 1) {

      #pass as reference
      $$formdata{$f} = \@ar;
    }

    #otherwise...
    else {

      #store single value under hash key
      if (defined $ar[0] && $ar[0] ne '--' && $ar[0] ne '' && !($ar[0] =~ m/^\s*$/)) {
        $$formdata{$f} = $ar[0];    #store form data in hash
      }
    }
  }
  return $formdata;
}

## @method void set_cookie($data, $insecure, $name, $uri)
# (Enter set_cookie info here)
# @param name  (Enter explanation for param here)
# @param insecure  (Enter explanation for param here)
# @param data  (Enter explanation for param here)
# @param uri  (Enter explanation for param here)
sub set_cookie {
  my ($self, $params) = @_;

  my $uri  = $$params{uri};
  my $name = $$params{name};
  my $data = $$params{data};
  my $cookie;

  if (!$$params{insecure}) {
    $self->check_https();

    $cookie = $self->get_req->cookie(
      -name    => $name,
      -value   => $data,
      -expires => '+24h',
      -secure  => 1
    );
  }
  else {
    $cookie = $self->get_req->cookie(
      -name    => $name,
      -value   => $data,
      -expires => '+24h',
    );
  }

  $self->forward({ cookie => $cookie, uri => $$params{uri} });

  return ();
}

## @method void print_header($filename, $mimetype, $pagetype)
# (Enter print_header info here)
# @param filename  (Enter explanation for param here)
# @param pagetype  (Enter explanation for param here)
# @param mimetype  (Enter explanation for param here)
sub print_header {
  my ($self, $params) = @_;

  if ($self->{header}) {
    return ();
  }

  my $pagetype = $$params{pagetype};

  # unless (defined $pagetype) {
  #   throw RWDE::DevelException({ info => 'Pagetype is not defined' });
  # }

  #if this is a standard webserver type
  if ($pagetype eq 'rwp') {
    print $self->get_req->header(
      -content_type => 'text/html; charset=utf-8',
      -pragma       => 'no-cache'
    );
    $self->{header} = 'true';
  }

  elsif ($pagetype eq 'ttml') {
    print $self->get_req->header(
      -content_type => 'text/html; charset=utf-8',
      -pragma       => 'no-cache'
    );
    $self->{header} = 'true';
  }

  elsif ($pagetype eq 'rss') {
    print $self->get_req->header(
      -content_type => 'text/xml; charset=utf-8',
      -pragma       => 'no-cache'
    );
    $self->{header} = 'true';
  }

  elsif ($pagetype eq 'bin') {

    # Ignore header printout request for .bin's
    # if all required elements are not set we'll
    # let the command print it out later.
    # This avoids the problem of special casing all
    # standard header printouts.
    if (not defined $$params{filename}) {
      return ();
    }

    print $self->get_req->header(
      -type       => $$params{mimetype},
      -attachment => $$params{filename}
    );
    $self->{header} = 'true';
  }

  return ();
}

## @method void forward($cookie, $uri)
# (Enter forward info here)
# @param cookie  (Enter explanation for param here)
# @param uri  (Enter explanation for param here)
sub forward {
  my ($self, $params) = @_;

  if ($self->{header}) {
    throw RWDE::DevelException({ info => 'Header was already sent to the client, redirect won\'t work' });
  }

  my $uri    = $$params{uri};
  my $cookie = $$params{cookie};
  print $self->get_req->redirect(
    -uri    => $uri,
    -nph    => 0,
    -cookie => $cookie,
    -status => '303 See Other'
  );

  $self->{header}  = 'true';
  $self->{forward} = 'true';

  # 301 - Moved Permanently
  # 302 - Found
  # 303 - See Other
  return ();
}

## @method void auth_required()
# (Enter auth_required info here)
sub auth_required {
  my ($self, $params) = @_;

  if ($self->{header}) {
    throw RWDE::DevelException({ info => 'Header was already sent to the client, redirect won\'t work' });
  }

  print $self->get_req->header(
    -status           => '401 Authorization Required',
    -WWW_authenticate => 'Basic realm="DiscussThis Archives"',
  );

  $self->{header} = 'true';

  # 401 - Authorization Required
  return ();
}

## @method object get_record()
# (Enter get_record info here)
# @return
sub get_record {
  my ($self, $params) = @_;

  my @proof;
  push(@proof, "Time: " . RWDE::Time->now, "Request: " . $self->get_req->script_name(), "IP: " . $self->get_req->remote_host(), "Agent: " . ($self->get_req->user_agent() || 'N/A'));

  my $record .= join("\n", @proof);

  return $record;
}

## @method object get_remote_ip()
# (Enter get_remote_ip info here)
# @return
sub get_remote_ip {
  my ($self, $params) = @_;
  return $self->get_req->remote_host();
}

## @method object get_referer()
# (Enter get_referer info here)
# @return
sub get_referer {
  my ($self, $params) = @_;

  return $self->get_req->referer();
}

## @method object get_contenttype()
# (Enter get_contenttype info here)
# @return
sub get_contenttype {
  my ($self, $params) = @_;

  my $file = $self->get_req->param('upload');

  my $info = $self->get_req->uploadInfo($file);

  return $info->{'Content-Type'};
}

1;