# Http.pm: Class Used for HTTP Requests

package RDA::Library::Http;

# $Id: Http.pm,v 1.12 2014/11/07 18:06:49 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Library/Http.pm,v 1.12 2014/11/07 18:06:49 RDA Exp $
#
# Change History
# 20141107  MSC  Add the refresh method.

=head1 NAME

RDA::Library::Http - Class Used for HTTP Requests

=head1 SYNOPSIS

 require RDA::Library::Http;

=head1 DESCRIPTION

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

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use RDA::Text qw(get_string);
  use RDA::Handle::Data;
  use RDA::Driver::Library;
  use RDA::Object;
  use RDA::Object::Cookie;
  use RDA::Object::Request;
  use RDA::Object::Response;
  use RDA::Object::UsrAgent;
  use RDA::Value::List;
  use RDA::Value::Scalar qw(:value);
}

# Define the global public variables
use vars qw($STRINGS $SUSPEND $VERSION @ISA);
$SUSPEND = {
  _max => 7,
  _uag => sub {return _init_user_agent($_[0]->{'_col'})},
  };
$VERSION = sprintf('%d.%02d', q$Revision: 1.12 $ =~ /(\d+)\.(\d+)/);
@ISA     = qw(RDA::Driver::Library Exporter);

# Define the global private constants
my $RPT = qr/^RDA::Object::(Pipe|Report)$/i;

# Define the global private variables
my %tb_fct = (
  'addCookie'       => [\&_m_add_cookie,      'O'],
  'addReqForm'      => [\&_m_req_add_form,    'N'],
  'clearCookieJar'  => [\&_m_clr_jar,         'O'],
  'clearReqForm'    => [\&_m_req_clr_form,    'O'],
  'createRequest'   => [\&_m_req_create,      'O'],
  'getCookieJar'    => [\&_m_get_jar,         'O'],
  'getPrevious'     => [\&_m_rsp_prev,        'O'],
  'getRspCode'      => [\&_m_rsp_get_code,    'L'],
  'getRspContent'   => [\&_m_rsp_get_content, 'L'],
  'getRspField'     => [\&_m_rsp_get_field,   'L'],
  'getRspKeys'      => [\&_m_rsp_get_keys,    'L'],
  'getRspMessage'   => [\&_m_rsp_get_message, 'T'],
  'getRspType'      => [\&_m_rsp_get_type,    'T'],
  'isRedirected'    => [\&_m_rsp_tst_redir,   'T'],
  'isSuccess'       => [\&_m_rsp_tst_success, 'T'],
  'loadResponse'    => [\&_m_rsp_load,        'O'],
  'needCredentials' => [\&_m_rsp_tst_cred,    'T'],
  'saveResponse'    => [\&_m_rsp_save,        'N'],
  'setCredentials'  => [\&_m_dft_set_cred,    'T'],
  'setDftField'     => [\&_m_dft_set_field,   'T'],
  'setDftTimeout'   => [\&_m_dft_set_timeout, 'N'],
  'setRedirection'  => [\&_m_dft_set_redir,   'T'],
  'setReqField'     => [\&_m_req_set_field,   'T'],
  'submitRequest'   => [\&_m_req_submit,      'O'],
  'writeResponse'   => [\&_m_rsp_write,       'N'],
  );

# Report the package version
sub Version
{ return $VERSION;
}

=head2 S<$h = RDA::Library::Http-E<gt>new($driver,$collector)>

The object constructor. It takes the library driver and collector references as
arguments.

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

=over 12

=item S<    B<'_col'> > Reference to the collector object

=item S<    B<'_err'> > Last error

=item S<    B<'_max'> > Maximum number of redirections

=item S<    B<'_req'> > HTTP request

=item S<    B<'_uag'> > User Agent reference

=back

Internal keys are prefixed by an underscore.

=cut

sub new
{ my ($cls, $drv, $col) = @_;
  my ($slf);

  # Create the macro object
  $slf = bless {
    _err => q{},
    _max => 7,
    _req => {typ => 'GET', url => q{}},
    }, ref($cls) || $cls;

  # Register the macros
  $drv->register($slf, [keys(%tb_fct)], qw(refresh suspend));

  # Return the object reference
  return refresh($slf, $col);
}

sub _init_user_agent
{ my ($col) = @_;
  my ($agt);

  $agt = RDA::Object::UsrAgent->new($col->get_trace('HTTP'));
  $agt->set_authen($col->get_access);
  return $agt;
}

=head2 S<$h-E<gt>call($name,...)>

This method executes the macro code.

=cut

sub call
{ my ($slf, $nam, @arg) = @_;

  return &{$tb_fct{$nam}->[0]}($slf, @arg);
}

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

This method deletes the library control object.

=cut

sub delete_object
{ RDA::Object::dump_caller($_[0], 'Library') if $RDA::Object::DELETE;
  undef %{$_[0]};
  undef $_[0];
  return;
}

=head2 S<$h-E<gt>refresh($col)>

This method updates the library control object for a new collector.

=cut

sub refresh
{ my ($slf, $col) = @_;

  $slf->{'_col'} = $col;
  $slf->{'_uag'} = _init_user_agent($col);
  return $slf;
}

=head2 S<$h-E<gt>run($name,$arg,$ctx)>

This method executes the macro with the specified argument list in a given
context.

=cut

sub run
{ my ($slf, $nam, $arg, $ctx) = @_;
  my ($fct, $ret, $typ);

  $fct = $tb_fct{$nam};
  $typ = $fct->[1];

  # Treat an array context
  return RDA::Value::List::new_from_data(&{$fct->[0]}($slf, $ctx,
    $arg->eval_as_array)) if $typ eq 'L';

  # Treat a scalar context
  return defined($ret = &{$fct->[0]}($slf, $ctx, $arg->eval_as_array))
    ? RDA::Value::Scalar->new($typ, $ret)
    : $VAL_UNDEF;
}

=head1 HTTP REQUEST MACROS

=head2 S<addCookie(nam=E<gt>$name,val=E<gt>$value,...)>

This macro adds a cookie in the user agent. It returns a reference to the
cookie jar.

=cut

sub _m_add_cookie
{ my ($slf, $ctx, @arg) = @_;

  return
    $slf->{'_uag'}->get_info('jar')->add_cookie(RDA::Object::Cookie->new(@arg));
}

=head2 S<addReqForm($req,$elm,...)>

This macro adds extra query elements to the request form. It returns the
number of elements in the form on successful completion. Otherwise, it returns
an undefined value.

=cut

sub _m_req_add_form
{ my ($slf, $ctx, $req, @arg) = @_;

  return (ref($req) eq 'RDA::Object::Request') ? $req->add_form(@arg) : undef;
}

=head2 S<clearCookieJar()>

This macro deletes all cookies and returns a reference to the cookie jar.

=cut

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

  return $slf->{'_uag'}->get_info('jar')->clear_cookies;
}

=head2 S<clearReqForm($req)>

This macro clears the form and the query part. It returns a reference to the
request object on successful completion. Otherwise, it returns an undefined
value.

=cut

sub _m_req_clr_form
{ my ($slf, $ctx, $req) = @_;

  return (ref($req) eq 'RDA::Object::Request') ? $req->clear_form : undef;
}

=head2 S<createRequest($type,$url)>

This macro creates a HTTP request and returns a request object.

=cut

sub _m_req_create
{ my ($slf, $ctx, $typ, $url) = @_;
  my $req;

  if ($typ && $url)
  { eval {$req = RDA::Object::Request->new($typ, $url);};
    return $req unless $@;
    $slf->{'_err'} = $@;
  }
  return;
}

=head2 S<getCookieJar()>

This macro returns a reference to the cookie jar.

=cut

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

  return $slf->{'_uag'}->get_info('jar');
}

=head2 S<getPrevious($rsp)>

This macro returns the previous response in case of redirections. Otherwise, it
returns an undefined value.

=cut

sub _m_rsp_prev
{ my ($slf, $ctx, $rsp) = @_;

  return (ref($rsp) eq 'RDA::Object::Response') ? $rsp->get_previous : undef;
}

=head2 S<getRspCode($rsp)>

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

=cut

sub _m_rsp_get_code
{ my ($slf, $ctx, $rsp) = @_;
  my (@sta);

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

=head2 S<getRspContent($rsp)>

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

=cut

sub _m_rsp_get_content
{ my ($slf, $ctx, $rsp) = @_;

  return () unless ref($rsp) eq 'RDA::Object::Response';
  return split(/\n/, join(q{},@{$rsp->get_content}));
}

=head2 S<getRspField($rsp,$key)>

This macro returns the value of the specified HTTP header field.

=cut

sub _m_rsp_get_field
{ my ($slf, $ctx, $rsp, $key) = @_;

  return (ref($rsp) eq 'RDA::Object::Response') ? $rsp->get_field($key) : undef;
}

=head2 S<getRspKeys($rsp)>

This macro returns the list of HTTP header fields present in the response.

=cut

sub _m_rsp_get_keys
{ my ($slf, $ctx, $rsp) = @_;

  return () unless ref($rsp) eq 'RDA::Object::Response';
  return $rsp->get_keys;
}

=head2 S<getRspMessage($rsp)>

This macro returns the HTTP response message.

=cut

sub _m_rsp_get_message
{ my ($slf, $ctx, $rsp) = @_;

  return (ref($rsp) eq 'RDA::Object::Response') ? $rsp->get_message : undef;
}

=head2 S<getRspType($rsp[,$dft])>

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

=cut

sub _m_rsp_get_type
{ my ($slf, $ctx, $rsp, $dft) = @_;

  $dft = $1 if ref($rsp) eq 'RDA::Object::Response'
    && $rsp->get_field('Content-Type') =~ m{^([^/]+/[^;\s]+)};
  return $dft;
}

=head2 S<isRedirected($rsp)>

This macro indicates if the request was redirected.

=cut

sub _m_rsp_tst_redir
{ my ($slf, $ctx, $rsp) = @_;

  return ref($rsp) eq 'RDA::Object::Response' && $rsp->is_redirected;
}

=head2 S<isSuccess($rsp)>

This macro indicates if the request was successful.

=cut

sub _m_rsp_tst_success
{ my ($slf, $ctx, $rsp) = @_;

  return ref($rsp) eq 'RDA::Object::Response' && $rsp->is_success;
}

=head2 S<loadResponse($obj[,$req])>

This macro decodes the Web response provided as message data or as buffer
content. On successful completion, it returns a reference to a response
object. Otherwise, it returns an undefined value.

=cut

sub _m_rsp_load  ## no critic (Complex)
{ my ($slf, $ctx, $obj, $req) = @_;
  my ($buf, $ifh, $key, $lgt, $lin, $off, $ref, $rsp, $str, $val);

  $ref = ref($obj);
  if ($ref eq 'RDA::Object::Message')
  { return $rsp unless ($ifh = RDA::Handle::Data->new($obj));
  }
  elsif ($ref eq 'RDA::Object::Buffer')
  { $ifh = $obj->get_handle;
  }
  else
  { return $rsp;
  }
  $rsp = RDA::Object::Response->new($req);

  # Read the whole header
  $buf = q{};
  $off = 0;
  while ($buf !~ m/^\015?\012/ && $buf !~ m/\015?\012\015?\012/)
  { $lgt = sysread($ifh, $buf, 1024, $off);
    die get_string('ERR_RESPONSE', $!) unless defined($lgt);
    last unless $lgt;
    $off += $lgt;
  }

  # Decode the header
  $key = q{};
  $str = $rsp->get_header;
  if ($buf =~ s{^(HTTP/(\d+\.\d+)\s+(\d+)\s*(.*?))\015?\012}{})
  { $rsp->set_error($3, $4);
    push(@{$str}, $1);
  }
  while ($buf =~ s{^(.*?)\015?\012}{})
  { $lin = $1;
    last unless length($lin);
    push(@{$str}, $lin);
    if ($lin =~ m{^([\w\-\.]+)\s*:\s*(.*)})
    { $rsp->set_field($key, $val) if $key;
      ($key, $val) = ($1, $2);
    }
    elsif ($lin =~ m{^\s+(.*)} && $key)
    { $val .= qq{ $1};
    }
  }
  $rsp->set_field($key, $val) if $key;

  # Get the response content
  $str = $rsp->get_content;
  push(@{$str}, $buf) if length($buf);
  for (;;)  ## no critic (Loop)
  { $lgt = sysread($ifh, $buf, 1024);
    die get_string('ERR_RESPONSE', $!) unless defined($lgt);
    last unless $lgt;
    push(@{$str}, $buf);
  }

  # Return a reference to the response object
  return $rsp;
}

=head2 S<needCredentials($rsp)>

This macro indicates whether the request requires credentials for execution. It
returns the related C<host:port/realm> combination. Otherwise, it returns an
undefined value.

=cut

sub _m_rsp_tst_cred
{ my ($slf, $ctx, $rsp) = @_;

  return (ref($rsp) eq 'RDA::Object::Response')
    ? $rsp->need_credentials
    : undef;
}

=head2 S<saveResponse([$rpt,]$rsp[,$re])>

This macro saves the response content as data in the report file. You can
specify a regular expression as an extra argument, to indicate from where it
must save the content.

It returns 1 on successful completion. Otherwise, it returns 0.

=cut

sub _m_rsp_save
{ my ($slf, $ctx, $arg, @arg) = @_;
  my ($rpt);

  return
    (ref($arg) =~ $RPT)       ? _s_rsp_save($slf, $ctx, $arg, @arg) :
    ($rpt = $ctx->get_report) ? _s_rsp_save($slf, $ctx, $rpt, $arg, @arg) :
                                0;
}

sub _s_rsp_save
{ my ($slf, $ctx, $rpt, $rsp, $pat) = @_;

  # Indicate that no output has been produced
  return 0 unless ref($rsp) eq 'RDA::Object::Response';

  # Write the response content in the report file
  if ($pat)
  { my ($buf);

    $buf = q{};
    $pat =~ s/\!/\\041/g;
    if ($pat =~ m/^([^!]+?)\#([ix]+)$/)
    { $pat = eval "qr!^(.*?)$1!s$2";  ## no critic (Eval)
      die get_string('ERR_PATTERN', $pat, $@) if $@;
    }
    elsif ($pat =~ m/^([^!]+)$/)
    { $pat = eval "qr!^(.*?)$1!s";  ## no critic (Eval)
      die get_string('ERR_PATTERN', $pat, $@) if $@;
    }
    else
    { die get_string('BAD_PATTERN', $pat);
    }
    for (@{$rsp->get_content})
    { if ($pat)
      { $buf .= $_;
        next unless $buf =~ $pat;
        $rpt->write(substr($buf, length($1)));
        $pat = undef;
      }
      else
      { $rpt->write($_);
      }
    }
  }
  else
  { for (@{$rsp->get_content})
    { $rpt->write($_);
    }
  }

  # Indicate the successful completion
  return 1;
}

=head2 S<setCredentials($key,$u_p)>

This macro associates credentials to a C<host:port/realm> combination.

=cut

sub _m_dft_set_cred
{ my ($slf, $ctx, $key, $u_p) = @_;

  return $slf->{'_uag'}->set_credentials($key,
    (ref($u_p)  =~ m/^RDA::Value::(Array|List)$/)
      ? $u_p->eval_as_data(1)
      : $u_p);
}

=head2 S<setDftField($key[,$value])>

This macro specifies a default HTTP header field. When the value is undefined,
it deletes the default HTTP header field.

It returns the old value.

=cut

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

  return $slf->{'_uag'}->set_field($key, $val);
}

=head2 S<setDftTimeout($timeout)>

This macro sets the HTTP timeout, specified in seconds, only if the value is
greater than zero. Otherwise, the timeout mechanism is disabled.

The effective value is returned.

=cut

sub _m_dft_set_timeout
{ my ($slf, $ctx, $val) = @_;

  return $slf->{'_uag'}->set_timeout($val);
}

=head2 S<setRedirection([$max])>

This macro specifies a new limit for the number of redirections. It returns the
previous value. When no value is specified, the current limit is not changed.

=cut

sub _m_dft_set_redir
{ my ($slf, $ctx, $max) = @_;

  my $old = $slf->{'_max'};
  $slf->{'_max'} = $max if defined($max) && $max >= 0;
  return $old;
}

=head2 S<setReqField($req,$key[,$value])>

This macro adds a HTTP header field in the request. When the value is
undefined, it deletes the HTTP header field.

It returns the old value.

=cut

sub _m_req_set_field
{ my ($slf, $ctx, $req, $key, $val) = @_;

  return (ref($req) eq 'RDA::Object::Request')
    ? $req->set_field($key, $val)
    : undef;
}

=head2 S<submitRequest($req)>

This macro submits a HTTP request and returns a response object.

=cut

sub _m_req_submit
{ my ($slf, $ctx, $req) = @_;

  return (ref($req) eq 'RDA::Object::Request')
    ? $slf->{'_uag'}->submit_request($req, $slf->{'_max'})
    : undef;
}

=head2 S<writeResponse([$rpt,]$rsp[,$flg])>

This macro writes the response content in the report file. When the flag is set,
it writes the body part of HTML responses only.

It returns 1 when the content has one or more lines. Otherwise, it returns 0.

=cut

sub _m_rsp_write
{ my ($slf, $ctx, $arg, @arg) = @_;
  my ($rpt);

  return
    (ref($arg) =~ $RPT)       ? _s_rsp_write($slf, $ctx, $arg, @arg) :
    ($rpt = $ctx->get_report) ? _s_rsp_write($slf, $ctx, $rpt, $arg, @arg) :
                                0;
}

sub _s_rsp_write
{ my ($slf, $ctx, $rpt, $rsp, $flg) = @_;
  my (@tbl);

  # Indicate that no output has been produced
  return 0
    unless ref($rsp) eq 'RDA::Object::Response'
    && (@tbl = split(/\015?\012/, join(q{},@{$rsp->get_content})));

  # Write the response content in the report file.
  if ($flg && $rsp->get_field('Content-Type') =~ m{^text/html\b})
  { my $sec = 0;
    for (@tbl)
    { if ($sec > 0)
      { $sec = 0 if s{</BODY.*$}{}i;
        $rpt->write(qq{$_\n});
        last unless $sec;
      }
      elsif ($sec < 0)
      { if (s{^[^>]*>}{})
        { $sec = 1;
          $rpt->write(qq{$_\n}) if $_;
        }
      }
      elsif (m{<BODY[^>]*>}i)
      { s{^.*<BODY[^>]*>}{}i;
        $sec = 1;
        $rpt->write(qq{$_\n}) if $_;
      }
      elsif (m{<BODY}i)
      { $sec = -1;
      }
    }
  }
  else
  { for (@tbl)
    { $rpt->write("$_\n");
    }
  }

  # Indicate the successful completion
  return 1;
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Driver::Library|RDA::Driver::Library>,
L<RDA::Handle::Data|RDA::Handle::Data>,
L<RDA::Object|RDA::Object>,
L<RDA::Object::Buffer|RDA::Object::Buffer>,
L<RDA::Object::Cookie|RDA::Object::Cookie>,
L<RDA::Object::Jar|RDA::Object::Jar>,
L<RDA::Object::Request|RDA::Object::Request>,
L<RDA::Object::Response|RDA::Object::Response>,
L<RDA::Object::UsrAgent|RDA::Object::UsrAgent>,
L<RDA::SDCL::Block|RDA::SDCL::Block>,
L<RDA::Text|RDA::Text>,
L<RDA::Value::List|RDA::Value::List>,
L<RDA::Value::Scalar|RDA::Value::Scalar>

=head1 COPYRIGHT NOTICE

Copyright (c) 2002, 2016, Oracle and/or its affiliates. All rights reserved.

=head1 TRADEMARK NOTICE

Oracle and Java are registered trademarks of Oracle and/or its
affiliates. Other names may be trademarks of their respective owners.

=cut