package RDA::Object::Request;

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

=head1 NAME

RDA::Object::Request - Class Used for Objects to Manage HTTP Requests

=head1 SYNOPSIS

require RDA::Object::Request;

=head1 DESCRIPTION

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

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use RDA::Object::Response;
}

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

# Define the global private variables

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

=head2 S<$h = RDA::Object::Request-E<gt>new($rsp[,$cred])>

The object constructor from a previous response.

=head2 S<$h = RDA::Object::Request-E<gt>new($typ,$url)>

The object constructor.

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

=over 16

=item B<    '-fld'     > Header fields

=item B<    '-frm'     > Form hash

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

=item B<    '-prt'     > URL port

=item B<    '-pth'     > URL path

=item B<    '-qry'     > URL query

=item B<    '-rsp'     > Redirecting response

=item B<    '-srv'     > URL server

=item B<    '-typ'     > Request type (method)

=item B<    '-url'     > Request URL

=back

When using the POST method, the query part of the URL is converted in content.

=cut

sub new
{ my ($cls, $typ, $str) = @_;
  my ($req, $slf);

  # Validate the request
  if (ref($typ) eq 'RDA::Object::Response')
  { $req = $typ->get_request;
    $slf = bless {
      '-fld' => { %{$req->{'-fld'}} },
      '-rsp' => $typ,
      '-typ' => $req->{'-typ'},
      }, $cls;
    if ($str)
    { $slf->{'-fld'}->{'Authorization'} = 'Basic '.$str;
      foreach my $key (qw(-prt -pth -qry -srv -url))
      { $slf->{$key} = $req->{$key} if exists($req->{$key});
      }
    }
    else
    { die "Missing location\n" unless ($str = $typ->get_field('Location'));
      _analyze_url($slf, $str);
    }
  }
  else
  { $typ = uc($typ);
    die "Invalid type: $typ\n" unless $typ eq 'GET' || $typ eq 'POST';
    $slf = bless {
      '-fld' => {},
      '-typ' => $typ,
      }, $cls;
    _analyze_url($slf, $str);
  }

  # Return the object reference
  $slf;
}

# Analyze the url
sub _analyze_url
{ my ($slf, $url) = @_;
  my ($pth, $qry);

  die "Unsupported url: $url\n"
    unless $url =~ m#^http://([^:/]+)(:(\d+))?(/.*)?$#;
  $slf->{'-url'} = $url;
  $slf->{'-srv'} = $1;
  $slf->{'-prt'} = $3 || 80;
  ($pth, $qry) = split(/\?/, $4) if defined($4);
  $slf->{'-pth'} = $pth || '/';
  $slf->{'-qry'} = $qry if defined($qry) && length($qry);
}

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

This method returns the request URL.

=cut

sub as_string
{ my ($slf) = @_;
  my ($buf);

  $slf->{'-qry'} = join('&', @{$slf->{'-frm'}})
    if exists($slf->{'-frm'}) && !exists($slf->{'-qry'});
  $buf = 'http://'.$slf->get_host.$slf->{'-pth'};
  $buf .= '?'.$slf->{'-qry'} 
    if exists($slf->{'-qry'}) && length($slf->{'-qry'});
  $buf;
}

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

This method dumps a HTTP request. It returns a reference to the request 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::Request\n";
  $slf;
}

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

This method returns the request content. It returns an undefined value for a
GET method or when the form is empty.

=cut

sub get_content
{ my ($slf) = @_;

  $slf->{'-qry'} = join('&', @{$slf->{'-frm'}})
    if exists($slf->{'-frm'}) && !exists($slf->{'-qry'});
  ($slf->{'-typ'} eq 'POST' && exists($slf->{'-qry'}) && length($slf->{'-qry'}))
    ? $slf->{'-qry'}
    : undef;
}

=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([$flag])>

This method returns the header field stack. When the flag is set, it also
clears the stack.

=cut

sub get_header
{ my ($slf, $flg) = @_;

  $slf->{'-hdr'} = [] if $flg || !exists($slf->{'-hdr'});
  $slf->{'-hdr'};
}

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

This method returns the host and port number of the resource being requested. A
host without any trailing port information implies the default port for the
service requested.

=cut

sub get_host
{ my ($slf) = @_;

  ($slf->{'-prt'} == 80) ? $slf->{'-srv'} : $slf->{'-srv'}.':'.$slf->{'-prt'};
}

=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_path>

This method returns the request path. For a GET method, it also includes the
query path, if any.

=cut

sub get_path
{ my ($slf) = @_;

  $slf->{'-qry'} = join('&', @{$slf->{'-frm'}})
    if exists($slf->{'-frm'}) && !exists($slf->{'-qry'});
  ($slf->{'-typ'} eq 'GET' && exists($slf->{'-qry'}) && length($slf->{'-qry'}))
    ? join('?', $slf->{'-pth'}, $slf->{'-qry'})
    : $slf->{'-pth'};
}


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

This method adds a HTTP header field. When the value is undefined, it deletes
the HTTP header field. It returns the old value.

=cut

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

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

=head1 FORM MANAGEMENT METHODS

=head2 S<$h-E<gt>add_form(...)>

This method adds extra query elements to the list. It returns the number of
elements in the form.

=cut

sub add_form
{ my $slf = shift;

  delete($slf->{'-qry'});
  $slf->{'-frm'} = [] unless exists($slf->{'-frm'});
  push(@{$slf->{'-frm'}}, @_);
}

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

This method clears the form and the query part. It returns the reference of the
request object.

=cut

sub clear_form
{ my ($slf) = @_;

  delete($slf->{'-qry'});
  delete($slf->{'-frm'});
  $slf;
}

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::Response|RDA::Object::Response>,
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