package RDA::Object::Response;

# $Id: Response.pm,v 1.15 2008/02/25 14:55:26 mschenke Exp $
# ARCS: $Header: /home/cvs/repository/RDA_4/src/scripting/lib/RDA/Object/Response.pm,v 1.15 2008/02/25 14:55:26 mschenke Exp $
#
# Change History
# 20080225  MSC  Change the copyright notice.

=head1 NAME

RDA::Object::Response - Class Used for Objects to Manage HTTP responses.

=head1 SYNOPSIS

require RDA::Object::Response;

=head1 DESCRIPTION

The objects of the C<RDA::Object::Response> class are used to manage HTTP
responses.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
}

# Define the global public variables
use vars qw($VERSION);
$VERSION = sprintf("%d.%02d", q$Revision: 1.15 $ =~ /(\d+)\.(\d+)/);

# Define the global private variables

# Report the module version number
sub Version
{ $VERSION;
}

=head2 S<$h = RDA::Object::Response-E<gt>new($req)>

The object constructor.

C<RDA::Object::Response> is represented by a blessed hash reference. The
following special keys are used:

=over 16

=item B<    '-cnt'     > Response content

=item B<    '-cod'     > HTTP code

=item B<    '-cok'     > Cookie list

=item B<    '-err'     > Response error

=item B<    '-fld'     > HTTP header fields

=item B<    '-hdr'     > HTTP header lines

=item B<    '-req'     > Related HTTP request

=back

=cut

sub new
{ my $cls = shift;
  my $req = shift;

  # Create the object
  my $slf = bless {
    '-cnt' => [],
    '-cod' => 500,
    '-err' => 'Invalid response',
    '-fld' => {},
    '-hdr' => [],
    '-req' => $req,
    }, $cls;

  # Return the object reference
  $slf;
}

=head2 S<$h-E<gt>as_string>

This method returns the response content as a string.

=cut

sub as_string
{ join('', @{shift->{'-cnt'}});
}

=head2 S<$h-E<gt>dump>

This method dumps a HTTP response. It returns a reference to the response
object.

=cut

sub dump
{ my $slf = shift;
  my $lvl = shift || 0;
  my ($pre, $ref);

  $pre = '  ' x $lvl;
  print $pre."bless {\n";
  foreach my $key (sort keys(%$slf))
  { $ref = ref($slf->{$key});
    if ($ref eq 'ARRAY')
    { print "$pre  $key => [\n";
      foreach my $lin (@{$slf->{$key}})
      { print "$pre    '$lin'\n";
      }
      print "$pre  ]\n";
    }
    elsif ($ref eq 'HASH')
    { print "$pre  $key => {\n";
      foreach my $itm (sort keys(%{$slf->{$key}}))
      { print "$pre    $itm => '".$slf->{$key}->{$itm}."'\n";
      }
      print "$pre  }\n";
    }
    elsif ($ref =~ m/^RDA::Object::/)
    { print "$pre  $key => $ref\n";
      $slf->{$key}->dump($lvl + 2);
    }
    elsif ($ref)
    { print "$pre  $key => $ref\n";
    }
    else
    { print "$pre  $key => '".$slf->{$key}."'\n";
    }
  }
  print "$pre}, RDA::Object::Response\n";
  $slf;
}

=head2 S<$h-E<gt>get_code>

This method returns the response code.

=cut

sub get_code
{ shift->{'-cod'};
}

=head2 S<$h-E<gt>get_codes>

This method returns the list of response HTTP codes, including the HTTP
response codes of all redirected requests.

=cut

sub get_codes
{ my ($slf) = @_;
  my (@sta);

  while (ref($slf) eq 'RDA::Object::Response')
  { push(@sta, $slf->{'-cod'});
    $slf = $slf->get_previous;
  }
  @sta;
}

=head2 S<$h-E<gt>get_content>

This method returns the response content.

=cut

sub get_content
{ shift->{'-cnt'};
}

=head2 S<$h-E<gt>get_field($key[,$dft])>

This method gets a HTTP header field value. When the field is not defined, it
returns the default value.

=cut

sub get_field
{ my ($slf, $key, $val) = @_;

  if ($key)
  { $key = lc($key);
    $key =~ s/\b([a-z])/\U$1/g;
    $val = $slf->{'-fld'}->{$key} if exists($slf->{'-fld'}->{$key});
  }
  $val;
}

=head2 S<$h-E<gt>get_header>

This method returns the response header.

=cut

sub get_header
{ shift->{'-hdr'};
}

=head2 S<$h-E<gt>get_info($key[,$dft])>

This method gets a request attribute value. When the attribute is not defined,
it returns the default value.

=cut

sub get_info
{ my ($slf, $key, $val) = @_;

  $val = $slf->{$key} if exists($slf->{$key});
  $val;
}

=head2 S<$h-E<gt>get_keys>

This method returns the list of defined HTTP header fields.

=cut

sub get_keys
{ sort keys(%{shift->{'-fld'}});
}

=head2 S<$h-E<gt>get_lines>

This method returns the response content as a list of lines.

=cut

sub get_lines
{ split(/\n/, join('',@{shift->get_content}));
}

=head2 S<$h-E<gt>get_message>

This method returns the response message.

=cut

sub get_message
{ shift->{'-err'};
}

=head2 S<$h-E<gt>get_previous>

This method returns the previous response. It returns an undefined value when
the request was not redirected.

=cut

sub get_previous
{ shift->{'-req'}->get_info('-rsp');
}

=head2 S<$h-E<gt>get_request>

This method returns the request that produces the specified response.

=cut

sub get_request
{ shift->{'-req'};
}


=head2 S<$h-E<gt>get_type([$dft])>

This method returns the HTTP response content MIME type. When the type is not
found, it returns the default value.

=cut

sub get_type
{ my ($slf, $dft) = @_;

  ($slf->get_field('Content-Type') =~ m#^([^/]+/[^;\s]+)#) ? $1 : $dft;
}

=head2 S<$h-E<gt>is_redirected>

This method indicates that the request was redirected.

=cut

sub is_redirected
{ my $cod = shift->{'-cod'};

  $cod == 301 || $cod == 302;
}

=head2 S<$h-E<gt>is_success>

This method indicates that the request was successful.

=cut

sub is_success
{ shift->{'-cod'} == 200;
}

=head2 S<$h-E<gt>need_credentials>

This method indicates that an authentication has been requested. RDA supports
basic authentication only at the moment. It returns the C<host:port/realm>
combination. Otherwise, it returns an undefined value for unsupported or failed
authentications.

=cut

sub need_credentials
{ my ($slf) = @_;
  my ($req, $str);

  # Determine if credentials are required
  $req = $slf->{'-req'};
  $str = exists($slf->{'-fld'}->{'Www-Authenticate'})
    ? $slf->{'-fld'}->{'Www-Authenticate'}
    : '';
  return undef unless $slf->{'-cod'} == 401
    && $str =~ m/^basic\s+realm="(.*)"/i
    && !$req->get_field('Authorization');

  # Determine the credentials entry.
  $req->get_info('-srv').':'.$req->get_info('-prt').'/'.$1;
}

=head2 S<$h-E<gt>set_error($sta,$err)>

This method specifies a response error.

=cut

sub set_error
{ my ($slf, $cod, $err) = @_;

  $err =~ s/[\n\r\s]+$//;
  $slf->{'-cod'} = $cod;
  $slf->{'-err'} = $err;
}

=head2 S<$h-E<gt>set_field($key,$val)>

This method adds a HTTP header field. It stores cookies separately.

=cut

sub set_field
{ my ($slf, $key, $val) = @_;

  $key = lc($key);
  if ($key eq 'set-cookie')
  { $slf->{'-cok'} = ['-'] unless exists($slf->{'-cok'});
    unshift(@{$slf->{'-cok'}}, $val);
  }
  elsif ($key eq 'set-cookie2')
  { $slf->{'-cok'} = ['-'] unless exists($slf->{'-cok'});
    push(@{$slf->{'-cok'}}, $val);
  }
  else
  { $key =~ s/\b([a-z])/\U$1/g;
    $val =~ s/^"(.*)"$/$1/;
    $slf->{'-fld'}->{$key} = $val;
  }
  $val;
}

1;

__END__

=head1 SEE ALSO

See also L<RDA::Agent|RDA::Agent>, L<RDA::Block|RDA::Block>,
L<RDA::Value|RDA::Value>,
L<RDA::Object::Buffer|RDA::Object::Buffer>,
L<RDA::Object::Cookie|RDA::Object::Cookie>,
L<RDA::Object::Data|RDA::Object::Data>,
L<RDA::Object::Html|RDA::Object::Html>,
L<RDA::Object::Jar|RDA::Object::Jar>,
L<RDA::Object::Parser|RDA::Object::Parser>,
L<RDA::Object::Request|RDA::Object::Request>,
L<RDA::Object::Sgml|RDA::Object::Sgml>,
L<RDA::Object::UsrAgent|RDA::Object::UsrAgent>,
L<RDA::Object::Xml|RDA::Object::Xml>,
L<RDA::Macro::Http|RDA::Macro::Http>.

=head1 COPYRIGHT NOTICE

Copyright (c) 2002-2008, Oracle. All rights reserved.

=head1 TRADEMARK NOTICE

Oracle, JD Edwards, PeopleSoft, and Siebel are registered trademarks of Oracle
Corporation and/or its affiliates. Other names may be trademarks of their
respective owners.

=cut