File Coverage

blib/lib/HTTP/DAV/Nginx.pm

Criterion	Covered	Total	%
statement	18	140	12.8
branch	0	34	0.0
condition	0	7	0.0
subroutine	6	20	30.0
pod	8	8	100.0
total	32	209	15.3

package HTTP::DAV::Nginx;

use strict;
use warnings;

use LWP::UserAgent;
use HTTP::Request;
use Carp;

our $VERSION = '0.1.6';

use constant C_BUF_SIZE => 8192;

#-----------
sub new
#-----------
{
	my $class = shift;
	my $url   = shift;
	my %param = @_;

	my $self = {};

	$self -> {'ua'} = new LWP::UserAgent;

	$url = _add_trailing_slash($url);
	$self -> {'url'} = $url;

	$self -> {'die_on_errors'} = $param{'die_on_errors'} || 0;
	$self -> {'warn_on_errors'} = $param{'warn_on_errors'} || 0;

	bless $self, $class;

	return $self;

}

#------------
sub _error
#------------
{
	my $self  = shift;
	my $error = shift;

	if ($self -> {'die_on_errors'})
	{
		croak $error;
	}
	if ($self -> {'warn_on_errors'})
	{
		carp $error;
	}

		$self -> {'err'} = $error;
}

#------------------------
sub _add_trailing_slash
#------------------------
{
	my $url = shift;

	$url =~ s|/$||;

	$url .= '/';

	return $url;
}

#--------------------------
sub _clear_begining_slash
#--------------------------
{
	my $uri = shift;

	$uri =~ s/^\///;

	return $uri;
}

#------------------
sub _read_file_cb
#------------------
{
	my $fh = shift;

	my $buffer;
	read($fh, $buffer, C_BUF_SIZE);

	return $buffer;
}



#----------
sub err
#----------
{
	my $self = shift;

	return $self -> {'err'};
}

#-----------
sub mkcol
#-----------
{
	my $self  = shift;
	my $uri   = shift;

	my $request = HTTP::Request->new();
	$request -> method('MKCOL');
	$request -> uri($self -> {'url'} . _clear_begining_slash($uri));

	my $response = $self -> {'ua'} -> request($request);

	unless ($response -> is_success)
	{
		$self -> _error("METHOD:MKCOL URI:$uri Status:" . $response -> status_line);
		return undef;
	}

	return 1;
}

#-------------
sub delete
#-------------
{
	my $self   = shift;
	my $uri    = shift;
	my %params = @_;

	my $request = HTTP::Request->new();
	$request -> method('DELETE');
	$request -> uri($self -> {'url'} . _clear_begining_slash($uri));

	$request -> header('Depth' => $params{'depth'}) if defined $params{'depth'};

	my $response = $self -> {'ua'} -> request($request);

	unless ($response -> is_success)
	{
		$self -> _error("METHOD:DELETE URI:$uri Status:" . $response -> status_line);
		return undef;
	}

	return 1;
}

#---------
sub put
#---------
{
	my $self      = shift;
	my $uri       = shift;
	my $data_type = shift;
	my $data      = shift;

	unless ($data && $data_type)
	{
		$self -> _error('METHOD:PUT ERROR:data not specified');
		return;
	}

	my $request = HTTP::Request -> new();
	$request -> method('PUT');
	$request -> uri($self -> {'url'} . _clear_begining_slash($uri));

	my $content;
	my $fh;

	if (lc($data_type) eq 'data')
	{
		$content = $data;
	}
	elsif (lc($data_type) eq 'file')
	{

		my $filename = $data;

		open($fh, '<:raw', $filename) or do
		{
			$self -> _error("Can't open file $data for reading");
			return;
		};
		binmode($fh);

		$request -> header('Content-length' => -s $filename);

		$content = sub { return _read_file_cb($fh) };
	}
	elsif (lc($data_type) eq 'fh')
	{
		my $fh = $data;
		my $filesize = (stat($fh))[7];

		binmode($fh);

		$request -> header('Content-length' => $filesize);

		$content = sub { return _read_file_cb($fh) };
	}

	$request -> content($content);

	my $response = $self -> {'ua'} -> request($request);

	unless ($response -> is_success)
	{
		$self -> _error("METHOD:PUT URI:$uri Status:" . $response -> status_line);
		return undef;
	}

	return 1;
}

#----------
sub copy
#----------
{
	my $self     = shift;
	my $uri      = shift;
	my $dest_uri = shift;
	my %params = @_;

	my $request = HTTP::Request->new();
	$request -> method('COPY');
	$request -> uri($self -> {'url'} . _clear_begining_slash($uri));
	$request -> header('Destination' => $dest_uri);

	$request -> header('Depth' => $params{'depth'}) if defined $params{'depth'};
	if (defined $params{'overwrite'})
	{
		$params{'overwrite'} =~ tr/01/FT/;
		$request -> header('Overwrite' => $params{'overwrite'});
	}

	my $response = $self -> {'ua'} -> request($request);
	unless ($response -> is_success)
	{
		$self -> _error("METHOD:COPY URI:$uri Status:" . $response -> status_line);
		return undef;
	}

	return 1;
}

#---------
sub move
#---------
{
	my $self     = shift;
	my $uri      = shift;
	my $dest_uri = shift;
	my %params = @_;

	my $request = HTTP::Request->new();
	$request -> method('MOVE');
	$request -> uri($self -> {'url'} . _clear_begining_slash($uri));
	$request -> header('Destination' => $dest_uri);

	$request -> header('Depth' => $params{'depth'}) if defined $params{'depth'};
	if (defined $params{'overwrite'})
	{
		$params{'overwrite'} =~ tr/01/FT/;
		$request -> header('Overwrite' => $params{'overwrite'});
	}
	my $response = $self -> {'ua'} -> request($request);
	unless ($response -> is_success)
	{
		$self -> _error("METHOD:MOVE URI:$uri Status:" . $response -> status_line);
		return undef;
	}

	return 1;
}

#--------------
sub useragent
#--------------
{
	my $self = shift;

	return $self -> {'ua'};
}

1;
__END__