File Coverage

blib/lib/Apache/Sling/Request.pm

Criterion	Covered	Total	%
statement	87	99	87.8
branch	33	40	82.5
condition	1	6	16.6
subroutine	10	10	100.0
pod	2	2	100.0
total	133	157	84.7

#!/usr/bin/perl -w

package Apache::Sling::Request;

use 5.008001;
use strict;
use warnings;
use Carp;
use HTTP::Request::Common qw(DELETE GET POST PUT);
use MIME::Base64;
use Apache::Sling::Print;

require Exporter;

use base qw(Exporter);

our @EXPORT_OK = ();

our $VERSION = '0.27';

#{{{sub string_to_request

sub string_to_request {
    my ( $string, $authn, $verbose, $log ) = @_;
    if ( !defined $string ) { croak 'No string defined to turn into request!'; }
    my $lwp = ${$authn}->{'LWP'};
    if ( !defined $lwp ) {
        croak 'No reference to an lwp user agent supplied!';
    }

    # Split based on the space character (\x20) only, such that
    # newlines, tabs etc are maintained in the request variables:
    my ( $action, $target, @req_variables ) = split /\x20/x, $string;
    $action = ( defined $action ? $action : '' );
    my $request;
    if ( $action eq 'post' ) {
        my $variables = join q{ }, @req_variables;
        my $post_variables;
        my $success = eval $variables;
        if ( !defined $success ) {
            croak "Error parsing post variables: \"$variables\"";
        }
        $request = POST( "$target", $post_variables );
    }
    if ( $action eq 'data' ) {

        # multi-part form upload
        my $variables = join q{ }, @req_variables;
        my $post_variables;
        my $success = eval $variables;
        if ( !defined $success ) {
            croak "Error parsing post variables: \"$variables\"";
        }
        $request =
          POST( "$target", $post_variables, 'Content_Type' => 'form-data' );
    }
    if ( $action eq 'fileupload' ) {

        # multi-part form upload with the file name and file specified
        my $filename  = shift @req_variables;
        my $file      = shift @req_variables;
        my $variables = join q{ }, @req_variables;
        my $post_variables;
        my $success = eval $variables;

        if ( !defined $success ) {
            croak "Error parsing post variables: \"$variables\"";
        }
        push @{$post_variables}, $filename => ["$file"];
        $request =
          POST( "$target", $post_variables, 'Content_Type' => 'form-data' );
    }
    if ( $action eq 'put' ) {
        $request = PUT "$target";
    }
    if ( $action eq 'delete' ) {
        $request = DELETE "$target";
    }
    if ( !defined $request ) {
        if ( defined $target ) {
            $request = GET "$target";
        }
        else {
            croak 'Error generating request for blank target!';
        }
    }
    if ( defined ${$authn}->{'Type'} ) {
        if ( ${$authn}->{'Type'} eq 'basic' ) {
            my $username = ${$authn}->{'Username'};
            my $password = ${$authn}->{'Password'};
            if ( defined $username && defined $password ) {

               # Always add an Authorization header to deal with application not
               # properly requesting authentication to be sent:
                my $encoded = 'Basic ' . encode_base64("$username:$password");
                $request->header( 'Authorization' => $encoded );
            }
        }
    }
    if ( defined $verbose && $verbose >= 2 ) {
        Apache::Sling::Print::print_with_lock(
            "**** String representation of compiled request:\n"
              . $request->as_string,
            $log
        );
    }
    return $request;
}

#}}}

#{{{sub request

sub request {
    my ( $object, $string ) = @_;
    if ( !defined $object ) {
        croak 'No reference to a suitable object supplied!';
    }
    if ( !defined $string ) { croak 'No string defined to turn into request!'; }
    my $authn = ${$object}->{'Authn'};
    if ( !defined $authn ) {
        croak 'Object does not reference a suitable auth object';
    }
    my $verbose = ${$object}->{'Verbose'};
    my $log     = ${$object}->{'Log'};
    my $lwp     = ${$authn}->{'LWP'};
    my $res =
      ${$lwp}->request( string_to_request( $string, $authn, $verbose, $log ) );
    return \$res;
}

#}}}

1;

__END__