package TUWF::Response;


use strict;
use warnings;
use Exporter 'import';
use POSIX 'strftime';


our $VERSION = '1.0';
our @EXPORT = qw|
  resInit resHeader resCookie resBuffer resFd resStatus resRedirect resNotFound resFinish
|;


# try to load PerlIO::gzip, resBuffer will check for its availability
eval { require PerlIO::gzip; };


# Initialises response data and resets all headers and content to their
# defaults. This method can be called mutliple times per request to clear
# any previous changes and to create a new response.
sub resInit {
  my $self = shift;

  $self->{_TUWF}{Res} = {
    status => 200,
    headers => [
      'Content-Type' => 'text/html; charset=UTF-8',
      'X-Powered-By' => 'Perl-TUWF',
    ],
    cookies => {},
    content => '',
  };

  # open output buffer
  $self->resBuffer($self->{_TUWF}{content_encoding}||'auto');
}


# Arguments       Action
#  name            returns list of values of the header, first found in scalar context, undef if not exists
#  name, value     sets header, overwrites existing header with same name, removes duplicates
#  name, undef     removes header
#  name, value, 1  adds header, not checking whether it already exists
# Header names are case-insensitive
sub resHeader {
  my($self, $name, $value, $add) = @_;
  my $h = $self->{_TUWF}{Res}{headers};

  if($add) {
    push @$h, $name, $value;
    return $value;
  }

  my @h;
  my @r;
  for (@$h ? 0..$#$h/2 : ()) {
    if(lc($h->[$_*2]) eq lc($name)) {
      push @h, $h->[$_*2+1];
      if(@_ == 3 && defined $value) {
        $h->[$_*2+1] = $value;
        push @r, $_ if @h > 1
      } elsif(@_ == 3) {
        push @r, $_;
      }
    }
  }

  push @$h, $name, $value if @_ == 3 && defined $value && !@h;

  splice @$h, $r[$_]*2-$_*2, 2
    for (@r ? 0..$#r : ());

  return @_ == 3 || @_ == 2 && !wantarray ? $h[0] : @h;
}


# Adds a Set-Cookie header, arguments:
# name, value, %options.
# value = undef -> remove cookie,
# options:
#   expires, path, domain, secure, httponly
sub resCookie {
  my $self = shift;
  my $name = shift;
  my $value = shift;
  my %o = ($self->{_TUWF}{cookie_defaults} ? %{$self->{_TUWF}{cookie_defaults}} : (), @_);

  $name = "$self->{_TUWF}{cookie_prefix}$name" if $self->{_TUWF}{cookie_prefix};
  my @attr = (sprintf '%s=%s', $name, defined($value)?$value:'');
  $o{expires} = 0 if !defined $value;

  push @attr, sprintf 'expires=%s', strftime("%a, %d %b %Y %H:%M:%S GMT", gmtime $o{expires}) if defined $o{expires};
  push @attr, "path=$o{path}" if $o{path};
  push @attr, "domain=$o{domain}" if $o{domain};
  push @attr, 'secure'   if $o{secure};
  push @attr, 'httponly' if $o{httponly};
  $self->{_TUWF}{Res}{cookies}{$name} = join '; ', @attr;
}


# Argument     Action
#  none/empty   Returns output compression type: none/gzip/deflate
#  'clear'      Clears the internal buffer, but doesn't change compression method
#  'none'       Clears buffer and disables output compression
#  'gzip'       Clears and enables gzip
#  'deflate'    Clears and enables deflate
#  'auto'       Clears and autodetects output compression from request header
# Enabling compression if PerlIO::gzip isn't installed will result in an error
sub resBuffer {
  my $self = shift;
  my $act = shift;
  my $i = $self->{_TUWF}{Res};

  my $h = $self->resHeader('Content-Encoding');
  $h = !$h ? 'none' : $h eq 'gzip' ? 'gzip' : $h eq 'deflate' ? 'deflate' : 'none';

  if($act) {
    my $new = $act eq 'clear' ? $h : $act;
    if($new eq 'auto') {
      # can we even do output compression?
      if(!defined $PerlIO::gzip::VERSION) {
        $new = 'none';
      }
      # seems like we can, figure out which encoding to use
      else {
        my $enc = $self->reqHeader('Accept-Encoding')||'';
        my $gzip = $enc !~ /gzip\s*(?:;\s*q=(\d+(?:\.\d*)?))?/ ? 0 : defined $1 ? $1 : 1;
        my $deflate = $enc !~ /deflate\s*(?:;\s*q=(\d+(?:\.\d*)?))?/ ? 0 : defined $1 ? $1 : 1;
        $new = !$gzip && !$deflate ? 'none' : $deflate > $gzip ? 'deflate' : 'gzip';
      }
    }

    # clear buffer
    close $i->{fd} if defined $i->{fd};
    $i->{content} = '';
    open $i->{fd}, '>', \$i->{content};

    # set output compression
    binmode $i->{fd}, $new eq 'gzip' ? ':gzip' : ':gzip(none)' if $new ne 'none';
    binmode $i->{fd}, ':utf8';
    $self->resHeader('Content-Encoding', $new eq 'none' ? undef : $new);
  }

  return $h;
}


# Returns the file descriptor where output functions can 'print' to
sub resFd {
  return shift->{_TUWF}{Res}{fd};
}


# Returns or sets the HTTP status
sub resStatus {
  my($self, $new) = @_;
  $self->{_TUWF}{Res}{status} = $new if $new;
  return $self->{_TUWF}{Res}{status};
}


# Redirect to an other page, accepts an URL (relative to current hostname) and
# an optional type consisting of 'temp' (temporary) or 'post' (after posting a form).
# No type argument means a permanent redirect.
sub resRedirect {
  my($self, $url, $type) = @_;

  $self->resInit;
  my $fd = $self->resFd();
  print $fd 'Redirecting...';
  $self->resHeader('Location' => $self->reqBaseURI().$url);
  $self->resStatus(!$type ? 301 : $type eq 'temp' ? 307 : 303);
}


sub resNotFound {
  my $self = shift;
  $self->resInit;
  $self->{_TUWF}{error_404_handler}->($self);
}


# Send everything we have buffered to the client
sub resFinish {
  my $self = shift;
  my $i = $self->{_TUWF}{Res};

  close $i->{fd};
  $self->resHeader('Content-Length' => length($i->{content}));

  printf "Status: %d\r\n", $i->{status};
  printf "%s: %s\r\n", $i->{headers}[$_*2], $i->{headers}[$_*2+1]
    for (0..$#{$i->{headers}}/2);
  printf "Set-Cookie: %s\r\n", $i->{cookies}{$_} for (keys %{$i->{cookies}});
  print  "\r\n";
  print  $i->{content} if $self->reqMethod() ne 'HEAD';

  # free the memory used for the reponse data
  $self->resInit;
}




1;