1# -*- perl -*- 2 3# Net::FTPServer A Perl FTP Server 4# Copyright (C) 2000 Bibliotech Ltd., Unit 2-3, 50 Carnwath Road, 5# London, SW6 3EG, United Kingdom. 6# 7# This program is free software; you can redistribute it and/or modify 8# it under the terms of the GNU General Public License as published by 9# the Free Software Foundation; either version 2 of the License, or 10# (at your option) any later version. 11# 12# This program is distributed in the hope that it will be useful, 13# but WITHOUT ANY WARRANTY; without even the implied warranty of 14# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15# GNU General Public License for more details. 16# 17# You should have received a copy of the GNU General Public License 18# along with this program; if not, write to the Free Software 19# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 20 21=pod 22 23=head1 NAME 24 25Net::FTPServer::DBeg1::IOBlob - The example DB FTP server personality 26 27=head1 SYNOPSIS 28 29 use Net::FTPServer::DBeg1::IOBlob; 30 31=head1 METHODS 32 33=cut 34 35package Net::FTPServer::DBeg1::IOBlob; 36 37use strict; 38 39use vars qw($VERSION); 40( $VERSION ) = '$Revision: 1.1 $ ' =~ /\$Revision:\s+([^\s]+)/; 41 42use DBI; 43use Carp qw(confess croak); 44 45=pod 46 47=over 4 48 49=item $io = Net::FTPServer::DBeg1::IOBlob ('r', $dbh, $blob_id); 50 51=item $io = Net::FTPServer::DBeg1::IOBlob ('w', $dbh, $blob_id); 52 53Create an IO handle for reading or writing a PostgreSQL blob. 54 55=cut 56 57sub new 58 { 59 my $class = shift; 60 my $mode = shift; 61 my $dbh = shift; 62 my $blob_id = shift; 63 64 # XXX For some reason PostgreSQL (6.4) fails when you call lo_open 65 # the first time. But if you retry a second time it succeeds. Therefore 66 # there is this hack. [RWMJ] 67 68 my $blob_fd; 69 70 for (my $retries = 0; !$blob_fd && $retries < 3; ++$retries) 71 { 72 $blob_fd = $dbh->func ($blob_id, 73 $mode eq 'r' ? $dbh->{pg_INV_READ} : $dbh->{pg_INV_WRITE}, 74 'lo_open'); 75 } 76 77 die "failed to open blob $blob_id: ", $dbh->errstr 78 unless $blob_fd; 79 80 my $self = { 81 mode => $mode, 82 dbh => $dbh, 83 blob_id => $blob_id, 84 blob_fd => $blob_fd 85 }; 86 bless $self, $class; 87 88 return $self; 89 } 90 91=item $io->getc (); 92 93Read 1 byte from the buffer and return it 94 95=cut 96 97sub getc 98 { 99 my $self = shift; 100 my $buffer; 101 if (defined $self->read ($buffer, 1)) { 102 return $buffer; 103 } else { 104 return undef; 105 } 106 } 107 108=item $io->read ($buffer, $nbytes, [$offset]); 109 110=item $io->sysread ($buffer, $nbytes, [$offset]); 111 112Read C<$nbytes> from the handle and place them in C<$buffer> 113at offset C<$offset>. 114 115=cut 116 117sub read 118 { 119 my $self = shift; 120 my $nbytes = $_[1]; 121 my $offset = $_[2] || 0; 122 123 $self->{dbh}->func ($self->{blob_fd}, substr ($_[0], $offset), $nbytes, 'lo_read'); 124 125 return $nbytes; 126 } 127 128sub sysread 129 { 130 my $self = shift; 131 my $nbytes = $_[1]; 132 my $offset = $_[2] || 0; 133 134 $self->{dbh}->func ($self->{blob_fd}, substr ($_[0], $offset), $nbytes, 'lo_read'); 135 136 return $nbytes; 137 } 138 139=item $io->write ($buffer, $nbytes, [$offset]); 140 141=item $io->syswrite ($buffer, $nbytes, [$offset]); 142 143Write C<$nbytes> to the handle from C<$buffer> offset C<$offset>. 144 145=cut 146 147sub write 148 { 149 my $self = shift; 150 my $nbytes = $_[1]; 151 my $offset = $_[2] || 0; 152 153 my $buffer = substr $_[0], $offset, $nbytes; 154 155 $self->{dbh}->func ($self->{blob_fd}, $buffer, length $buffer, 'lo_write'); 156 157 return $nbytes; 158 } 159 160sub syswrite 161 { 162 my $self = shift; 163 my $nbytes = $_[1]; 164 my $offset = $_[2] || 0; 165 166 my $buffer = substr $_[0], $offset, $nbytes; 167 168 $self->{dbh}->func ($self->{blob_fd}, $buffer, length $buffer, 'lo_write'); 169 170 return $nbytes; 171 } 172 173=item $io->print ($buffer); 174 175=cut 176 177sub print 178 { 179 my $self = shift; 180 my $buffer = join "", @_; 181 182 return $self->write ($buffer, length $buffer); 183 } 184 185=item $io->close; 186 187Close the IO handle. 188 189=cut 190 191sub close 192 { 193 my $self = shift; 194 195 if ($self->{dbh}) 196 { 197 $self->{dbh}->func ($self->{blob_fd}, 'lo_close'); 198 delete $self->{dbh}; 199 } 200 201 return 1; 202 } 203 204sub DESTROY 205 { 206 shift->close; 207 } 208 2091 # So that the require or use succeeds. 210 211__END__ 212 213=back 214 215=head1 AUTHORS 216 217Richard Jones (rich@annexia.org). 218 219=head1 COPYRIGHT 220 221Copyright (C) 2000 Biblio@Tech Ltd., Unit 2-3, 50 Carnwath Road, 222London, SW6 3EG, UK 223 224=head1 SEE ALSO 225 226C<Net::FTPServer(3)>, C<perl(1)> 227 228=cut 229