File Coverage

blib/lib/Tie/FTP.pm

Criterion	Covered	Total	%
statement	42	74	56.7
branch	9	16	56.2
condition	1	2	50.0
subroutine	13	26	50.0
pod	0	6	0.0
total	65	124	52.4

#!/usr/bin/perl

package Tie::FTP;

use strict;
use warnings;

use File::Temp ();
use URI;
use Net::FTP;

our $VERSION = 0.02;

sub TIEHANDLE { # uri object || uri || netftp object, path
	my $pkg = shift || return undef;

	my ($tmpfh,$tmpnm) = File::Temp::tmpnam();

	my $self = bless { tmpfile => $tmpnm, tmpfh => $tmpfh},$pkg;

	$self;
}

sub OPEN {
	my $self = shift;

	if (scalar @_ > 1){
		$self->ftp(shift);
		$self->path(shift);
	} else { # uri or uri object
		my $uri = shift;
		$uri = URI->new($uri) unless ref $uri;
		return undef unless $uri->scheme eq 'ftp';

		$self->ftp(Net::FTP->new($uri->host));
		$self->ftp->login(split(':',$uri->userinfo));
		$self->path(substr($uri->path,1));
	}

	$self->ftp->get($self->path,$self->tmpfile);
}

sub tmpfile { # set to use a tempfile instead of writing and reading via net. overrides cache
	my $self = shift;
	$self->{tmpfile} = shift if @_;
	$self->{tmpfile};
}

sub tmpfh {
	my $self = shift;
	$self->{tmpfh} = shift if @_;
	$self->{tmpfh};
}

sub ftp {
	my $self = shift;
	$self->{ftp} = shift if @_;
	$self->{ftp};
}

sub path {
	my $self = shift;
	$self->{path} = shift if @_;
	$self->{path};
}

sub taint {
	my $self = shift;
	$self->{tainted} = 1;
}

sub tainted {
	my $self = shift;
	$self->{tainted};
}

sub CLOSE {
	goto &UNTIE;
}

sub UNTIE { }

sub DESTROY {
	my $self = shift;
	close $self->tmpfh;
	$self->ftp->put($self->tmpfile,$self->path) if $self->tainted;
	unlink $self->tmpfile;
}


sub WRITE { $_[0]->taint; my $fh = $_[0]{tmpfh}; print $fh substr($_[1],$_[3],$_[2]) }
sub PRINT { $_[0]->taint; my $fh = shift->{tmpfh}; print $fh @_ }
sub PRINTF { $_[0]->taint; my $fh = shift->{tmpfh}; printf $fh @_ }
sub READ { read *{$_[0]{tmpfh}},$_[1],$_[2],$_[3] }
sub READLINE { readline $_[0]{tmpfh} }
sub GETC { getc *{$_[0]{tmpfh}} }
sub BINMODE{ binmode *{$_[0]{tmpfh}} }
sub EOF { eof *{$_[0]{tmpfh}} }
sub TELL { tell *{$_[0]{tmpfh}} }
sub SEEK { seek *{$_[0]{tmpfh}},$_[1],$_[2] }

1; # Keep your mother happy.

__END__