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