ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Net-FCP/FCP.pm
(Generate patch)

Comparing Net-FCP/FCP.pm (file contents):
Revision 1.8 by root, Mon Sep 8 01:47:31 2003 UTC vs.
Revision 1.19 by root, Sun Sep 14 09:48:01 2003 UTC

… …
17of what the messages do. I am too lazy to document all this here. 17of what the messages do. I am too lazy to document all this here.
18 18
19=head1 WARNING 19=head1 WARNING
20 20
21This module is alpha. While it probably won't destroy (much :) of your 21This module is alpha. While it probably won't destroy (much :) of your
22data, it currently works only with the Event module (alkthough the event 22data, it currently falls short of what it should provide (intelligent uri
23mechanism is fully pluggable). 23following, splitfile downloads, healing...)
24
25=head2 IMPORT TAGS
26
27Nothing much can be "imported" from this module right now. There are,
28however, certain "import tags" that can be used to select the event model
29to be used.
30
31Event models are implemented as modules under the C<Net::FCP::Event::xyz>
32class, where C<xyz> is the event model to use. The default is C<Event> (or
33later C<Auto>).
34
35The import tag to use is named C<event=xyz>, e.g. C<event=Event>,
36C<event=Glib> etc.
37
38You should specify the event module to use only in the main program.
39
40=head2 FREENET BASICS
41
42Ok, this section will not explain any freenet basics to you, just some
43problems I found that you might want to avoid:
44
45=over 4
46
47=item freenet URIs are _NOT_ URIs
48
49Whenever a "uri" is required by the protocol, freenet expects a kind of
50URI prefixed with the "freenet:" scheme, e.g. "freenet:CHK...". However,
51these are not URIs, as freeent fails to parse them correctly, that is, you
52must unescape an escaped characters ("%2c" => ",") yourself. Maybe in the
53future this library will do it for you, so watch out for this incompatible
54change.
55
56=item Numbers are in HEX
57
58Virtually every number in the FCP protocol is in hex. Be sure to use
59C<hex()> on all such numbers, as the module (currently) does nothing to
60convert these for you.
61
62=back
24 63
25=head2 THE Net::FCP CLASS 64=head2 THE Net::FCP CLASS
26 65
27=over 4 66=over 4
28 67
29=cut 68=cut
30 69
31package Net::FCP; 70package Net::FCP;
32 71
33use Carp; 72use Carp;
34use IO::Socket::INET;
35 73
36$VERSION = 0.04; 74$VERSION = 0.08;
37 75
38sub event_reg_cb { 76no warnings;
39 my ($obj) = @_;
40 require Event;
41 77
42 $obj->{eventdata} = Event->io ( 78our $EVENT = Net::FCP::Event::Auto::;
43 fd => $obj->{fh}, 79$EVENT = Net::FCP::Event::Event;#d#
44 poll => 'r', 80
45 cb => sub { 81sub import {
46 $obj->fh_ready; 82 shift;
83
84 for (@_) {
85 if (/^event=(\w+)$/) {
86 $EVENT = "Net::FCP::Event::$1";
47 }, 87 }
48 ); 88 }
89 eval "require $EVENT";
90 die $@ if $@;
49} 91}
50
51sub event_unreg_cb {
52 $_[0]{eventdata}
53 and (delete $_[0]{eventdata})->cancel;
54}
55
56sub event_wait_cb {
57 Event::one_event();
58}
59
60$regcb = \&event_reg_cb;
61$unregcb = \&event_unreg_cb;
62$waitcb = \&event_wait_cb;
63 92
64sub touc($) { 93sub touc($) {
65 local $_ = shift; 94 local $_ = shift;
66 1 while s/((?:^|_)(?:svk|chk|uri)(?:_|$))/\U$1/; 95 1 while s/((?:^|_)(?:svk|chk|uri)(?:_|$))/\U$1/;
67 s/(?:^|_)(.)/\U$1/g; 96 s/(?:^|_)(.)/\U$1/g;
… …
88 117
89 ( 118 (
90 version => { revision => 1 }, 119 version => { revision => 1 },
91 document => [ 120 document => [
92 { 121 {
93 "info.format" => "image/jpeg", 122 info => { format" => "image/jpeg" },
94 name => "background.jpg", 123 name => "background.jpg",
95 "redirect.target" => "freenet:CHK\@ZcagI,ra726bSw" 124 redirect => { target => "freenet:CHK\@ZcagI,ra726bSw" },
96 }, 125 },
97 { 126 {
98 "info.format" => "text/html", 127 info => { format" => "text/html" },
99 name => ".next", 128 name => ".next",
100 "redirect.target" => "freenet:SSK\@ilUPAgM/TFEE/3" 129 redirect => { target => "freenet:SSK\@ilUPAgM/TFEE/3" },
101 }, 130 },
102 { 131 {
103 "info.format" => "text/html", 132 info => { format" => "text/html" },
104 "redirect.target" => "freenet:CHK\@8M8Po8ucwI,8xA" 133 redirect => { target => "freenet:CHK\@8M8Po8ucwI,8xA" },
105 } 134 }
106 ] 135 ]
107 ) 136 )
108 137
109=cut 138=cut
… …
116 my $hdr = $meta->{version} = {}; 145 my $hdr = $meta->{version} = {};
117 146
118 for (;;) { 147 for (;;) {
119 while ($data =~ /\G([^=\015\012]+)=([^\015\012]*)\015?\012/gc) { 148 while ($data =~ /\G([^=\015\012]+)=([^\015\012]*)\015?\012/gc) {
120 my ($k, $v) = ($1, $2); 149 my ($k, $v) = ($1, $2);
121 $hdr->{tolc $k} = $v; 150 my @p = split /\./, tolc $k, 3;
151
152 $hdr->{$p[0]} = $v if @p == 1; # lamest code I ever wrote
153 $hdr->{$p[0]}{$p[1]} = $v if @p == 2;
154 $hdr->{$p[0]}{$p[1]}{$p[2]} = $v if @p == 3;
155 die "FATAL: 4+ dot metadata" if @p >= 4;
122 } 156 }
123 157
124 if ($data =~ /\GEndPart\015?\012/gc) { 158 if ($data =~ /\GEndPart\015?\012/gc) {
159 # nop
125 } elsif ($data =~ /\GEnd\015?\012/gc) { 160 } elsif ($data =~ /\GEnd(\015?\012|$)/gc) {
126 last; 161 last;
127 } elsif ($data =~ /\G([A-Za-z0-9.\-]+)\015?\012/gcs) { 162 } elsif ($data =~ /\G([A-Za-z0-9.\-]+)\015?\012/gcs) {
128 push @{$meta->{tolc $1}}, $hdr = {}; 163 push @{$meta->{tolc $1}}, $hdr = {};
129 } elsif ($data =~ /\G(.*)/gcs) { 164 } elsif ($data =~ /\G(.*)/gcs) {
165 print STDERR "metadata format error ($1), please report this string: <<$data>>";
130 die "metadata format error ($1)"; 166 die "metadata format error";
131 } 167 }
132 } 168 }
133 } 169 }
134 170
135 #$meta->{tail} = substr $data, pos $data; 171 #$meta->{tail} = substr $data, pos $data;
… …
141 177
142Create a new virtual FCP connection to the given host and port (default 178Create a new virtual FCP connection to the given host and port (default
143127.0.0.1:8481, or the environment variables C<FREDHOST> and C<FREDPORT>). 179127.0.0.1:8481, or the environment variables C<FREDHOST> and C<FREDPORT>).
144 180
145Connections are virtual because no persistent physical connection is 181Connections are virtual because no persistent physical connection is
182established.
183
184=begin comment
185
146established. However, the existance of the node is checked by executing a 186However, the existance of the node is checked by executing a
147C<ClientHello> transaction. 187C<ClientHello> transaction.
188
189=end
148 190
149=cut 191=cut
150 192
151sub new { 193sub new {
152 my $class = shift; 194 my $class = shift;
153 my $self = bless { @_ }, $class; 195 my $self = bless { @_ }, $class;
154 196
155 $self->{host} ||= $ENV{FREDHOST} || "127.0.0.1"; 197 $self->{host} ||= $ENV{FREDHOST} || "127.0.0.1";
156 $self->{port} ||= $ENV{FREDPORt} || 8481; 198 $self->{port} ||= $ENV{FREDPORT} || 8481;
157 199
158 $self->{nodehello} = $self->client_hello 200 #$self->{nodehello} = $self->client_hello
159 or croak "unable to get nodehello from node\n"; 201 # or croak "unable to get nodehello from node\n";
160 202
161 $self; 203 $self;
162} 204}
163 205
206sub progress {
207 my ($self, $txn, $type, $attr) = @_;
208 #warn "progress<$txn,$type," . (join ":", %$attr) . ">\n";
209}
210
164=item $txn = $fcp->txn(type => attr => val,...) 211=item $txn = $fcp->txn(type => attr => val,...)
165 212
166The low-level interface to transactions. Don't use it. 213The low-level interface to transactions. Don't use it.
214
215Here are some examples of using transactions:
216
217The blocking case, no (visible) transactions involved:
218
219 my $nodehello = $fcp->client_hello;
220
221A transaction used in a blocking fashion:
222
223 my $txn = $fcp->txn_client_hello;
224 ...
225 my $nodehello = $txn->result;
226
227Or shorter:
228
229 my $nodehello = $fcp->txn_client_hello->result;
230
231Setting callbacks:
232
233 $fcp->txn_client_hello->cb(
234 sub { my $nodehello => $_[0]->result }
235 );
167 236
168=cut 237=cut
169 238
170sub txn { 239sub txn {
171 my ($self, $type, %attr) = @_; 240 my ($self, $type, %attr) = @_;
… …
175 my $txn = "Net::FCP::Txn::$type"->new(fcp => $self, type => tolc $type, attr => \%attr); 244 my $txn = "Net::FCP::Txn::$type"->new(fcp => $self, type => tolc $type, attr => \%attr);
176 245
177 $txn; 246 $txn;
178} 247}
179 248
180sub _txn($&) { 249{ # transactions
250
251my $txn = sub {
181 my ($name, $sub) = @_; 252 my ($name, $sub) = @_;
182 *{"$name\_txn"} = $sub; 253 *{"txn_$name"} = $sub;
183 *{$name} = sub { $sub->(@_)->result }; 254 *{$name} = sub { $sub->(@_)->result };
184} 255};
185 256
186=item $txn = $fcp->txn_client_hello 257=item $txn = $fcp->txn_client_hello
187 258
188=item $nodehello = $fcp->client_hello 259=item $nodehello = $fcp->client_hello
189 260
… …
195 protocol => "1.2", 266 protocol => "1.2",
196 } 267 }
197 268
198=cut 269=cut
199 270
200_txn client_hello => sub { 271$txn->(client_hello => sub {
201 my ($self) = @_; 272 my ($self) = @_;
202 273
203 $self->txn ("client_hello"); 274 $self->txn ("client_hello");
204}; 275});
205 276
206=item $txn = $fcp->txn_client_info 277=item $txn = $fcp->txn_client_info
207 278
208=item $nodeinfo = $fcp->client_info 279=item $nodeinfo = $fcp->client_info
209 280
… …
233 routing_time => "a5", 304 routing_time => "a5",
234 } 305 }
235 306
236=cut 307=cut
237 308
238_txn client_info => sub { 309$txn->(client_info => sub {
239 my ($self) = @_; 310 my ($self) = @_;
240 311
241 $self->txn ("client_info"); 312 $self->txn ("client_info");
242}; 313});
243 314
244=item $txn = $fcp->txn_generate_chk ($metadata, $data) 315=item $txn = $fcp->txn_generate_chk ($metadata, $data)
245 316
246=item $uri = $fcp->generate_chk ($metadata, $data) 317=item $uri = $fcp->generate_chk ($metadata, $data)
247 318
248Creates a new CHK, given the metadata and data. UNTESTED. 319Creates a new CHK, given the metadata and data. UNTESTED.
249 320
250=cut 321=cut
251 322
252_txn generate_chk => sub { 323$txn->(generate_chk => sub {
253 my ($self, $metadata, $data) = @_; 324 my ($self, $metadata, $data) = @_;
254 325
255 $self->txn (generate_chk => data => "$data$metadata", metadata_length => length $metadata); 326 $self->txn (generate_chk => data => "$metadata$data", metadata_length => length $metadata);
256}; 327});
257 328
258=item $txn = $fcp->txn_generate_svk_pair 329=item $txn = $fcp->txn_generate_svk_pair
259 330
260=item ($public, $private) = @{ $fcp->generate_svk_pair } 331=item ($public, $private) = @{ $fcp->generate_svk_pair }
261 332
… …
266 "ZnmvMITaTXBMFGl4~jrjuyWxOWg" 337 "ZnmvMITaTXBMFGl4~jrjuyWxOWg"
267 ] 338 ]
268 339
269=cut 340=cut
270 341
271_txn generate_svk_pair => sub { 342$txn->(generate_svk_pair => sub {
272 my ($self) = @_; 343 my ($self) = @_;
273 344
274 $self->txn ("generate_svk_pair"); 345 $self->txn ("generate_svk_pair");
275}; 346});
276 347
277=item $txn = $fcp->txn_insert_private_key ($private) 348=item $txn = $fcp->txn_insert_private_key ($private)
278 349
279=item $uri = $fcp->insert_private_key ($private) 350=item $public = $fcp->insert_private_key ($private)
280 351
281Inserts a private key. $private can be either an insert URI (must start 352Inserts a private key. $private can be either an insert URI (must start
282with freenet:SSK@) or a raw private key (i.e. the private value you get back 353with C<freenet:SSK@>) or a raw private key (i.e. the private value you get
283from C<generate_svk_pair>). 354back from C<generate_svk_pair>).
284 355
285Returns the public key. 356Returns the public key.
286 357
287UNTESTED. 358UNTESTED.
288 359
289=cut 360=cut
290 361
291_txn insert_private_key => sub { 362$txn->(insert_private_key => sub {
292 my ($self, $privkey) = @_; 363 my ($self, $privkey) = @_;
293 364
294 $self->txn (invert_private_key => private => $privkey); 365 $self->txn (invert_private_key => private => $privkey);
295}; 366});
296 367
297=item $txn = $fcp->txn_get_size ($uri) 368=item $txn = $fcp->txn_get_size ($uri)
298 369
299=item $length = $fcp->get_size ($uri) 370=item $length = $fcp->get_size ($uri)
300 371
… …
303 374
304UNTESTED. 375UNTESTED.
305 376
306=cut 377=cut
307 378
308_txn get_size => sub { 379$txn->(get_size => sub {
309 my ($self, $uri) = @_; 380 my ($self, $uri) = @_;
310 381
311 $self->txn (get_size => URI => $uri); 382 $self->txn (get_size => URI => $uri);
312}; 383});
313 384
314=item $txn = $fcp->txn_client_get ($uri [, $htl = 15 [, $removelocal = 0]]) 385=item $txn = $fcp->txn_client_get ($uri [, $htl = 15 [, $removelocal = 0]])
315 386
316=item ($metadata, $data) = @{ $fcp->client_get ($uri, $htl, $removelocal) 387=item ($metadata, $data) = @{ $fcp->client_get ($uri, $htl, $removelocal)
317 388
… …
327 ) 398 )
328 }; 399 };
329 400
330=cut 401=cut
331 402
332_txn client_get => sub { 403$txn->(client_get => sub {
333 my ($self, $uri, $htl, $removelocal) = @_; 404 my ($self, $uri, $htl, $removelocal) = @_;
334 405
335 $self->txn (client_get => URI => $uri, hops_to_live => ($htl || 15), remove_local => $removelocal*1); 406 $self->txn (client_get => URI => $uri, hops_to_live => (defined $htl ? $htl :15),
407 remove_local_key => $removelocal ? "true" : "false");
336}; 408});
337 409
410=item $txn = $fcp->txn_client_put ($uri, $metadata, $data, $htl, $removelocal)
411
412=item my $uri = $fcp->client_put ($uri, $metadata, $data, $htl, $removelocal);
413
414Insert a new key. If the client is inserting a CHK, the URI may be
415abbreviated as just CHK@. In this case, the node will calculate the
416CHK.
417
418C<$meta> can be a reference or a string (ONLY THE STRING CASE IS IMPLEMENTED!).
419
420THIS INTERFACE IS UNTESTED AND SUBJECT TO CHANGE.
421
422=cut
423
424$txn->(client_put => sub {
425 my ($self, $uri, $meta, $data, $htl, $removelocal) = @_;
426
427 $self->txn (client_put => URI => $uri, hops_to_live => (defined $htl ? $htl :15),
428 remove_local_key => $removelocal ? "true" : "false",
429 data => "$meta$data", metadata_length => length $meta);
430});
431
432} # transactions
433
338=item MISSING: ClientPut 434=item MISSING: (ClientPut), InsretKey
339 435
340=back 436=back
341 437
342=head2 THE Net::FCP::Txn CLASS 438=head2 THE Net::FCP::Txn CLASS
343 439
… …
354 450
355=cut 451=cut
356 452
357package Net::FCP::Txn; 453package Net::FCP::Txn;
358 454
455use Fcntl;
456use Socket;
457
359=item new arg => val,... 458=item new arg => val,...
360 459
361Creates a new C<Net::FCP::Txn> object. Not normally used. 460Creates a new C<Net::FCP::Txn> object. Not normally used.
362 461
363=cut 462=cut
364 463
365sub new { 464sub new {
366 my $class = shift; 465 my $class = shift;
367 my $self = bless { @_ }, $class; 466 my $self = bless { @_ }, $class;
467
468 $self->{signal} = $EVENT->new_signal;
469
470 $self->{fcp}{txn}{$self} = $self;
368 471
369 my $attr = ""; 472 my $attr = "";
370 my $data = delete $self->{attr}{data}; 473 my $data = delete $self->{attr}{data};
371 474
372 while (my ($k, $v) = each %{$self->{attr}}) { 475 while (my ($k, $v) = each %{$self->{attr}}) {
… …
378 $data = "Data\012$data"; 481 $data = "Data\012$data";
379 } else { 482 } else {
380 $data = "EndMessage\012"; 483 $data = "EndMessage\012";
381 } 484 }
382 485
383 my $fh = new IO::Socket::INET 486 socket my $fh, PF_INET, SOCK_STREAM, 0
384 PeerHost => $self->{fcp}{host}, 487 or Carp::croak "unable to create new tcp socket: $!";
385 PeerPort => $self->{fcp}{port}
386 or Carp::croak "FCP::txn: unable to connect to $self->{fcp}{host}:$self->{fcp}{port}: $!\n";
387
388 binmode $fh, ":raw"; 488 binmode $fh, ":raw";
489 fcntl $fh, F_SETFL, O_NONBLOCK;
490 connect $fh, (sockaddr_in $self->{fcp}{port}, inet_aton $self->{fcp}{host})
491 and !$!{EWOULDBLOCK}
492 and !$!{EINPROGRESS}
493 and Carp::croak "FCP::txn: unable to connect to $self->{fcp}{host}:$self->{fcp}{port}: $!\n";
389 494
390 if (0) { 495 $self->{sbuf} =
391 print 496 "\x00\x00\x00\x02"
392 Net::FCP::touc $self->{type}, "\012",
393 $attr,
394 $data, "\012";
395 }
396
397 print $fh
398 "\x00\x00", "\x00\x02", # SESSID, PRESID
399 Net::FCP::touc $self->{type}, "\012", 497 . Net::FCP::touc $self->{type}
400 $attr, 498 . "\012$attr$data";
401 $data;
402 499
403 #$fh->shutdown (1); # freenet buggy?, well, it's java... 500 #$fh->shutdown (1); # freenet buggy?, well, it's java...
404 501
405 $self->{fh} = $fh; 502 $self->{fh} = $fh;
406 503
407 $Net::FCP::regcb->($self); 504 $self->{w} = $EVENT->new_from_fh ($fh)->cb(sub { $self->fh_ready_w })->poll(0, 1, 1);
408 505
409 $self; 506 $self;
410} 507}
411 508
509=item $txn = $txn->cb ($coderef)
510
511Sets a callback to be called when the request is finished. The coderef
512will be called with the txn as it's sole argument, so it has to call
513C<result> itself.
514
515Returns the txn object, useful for chaining.
516
517Example:
518
519 $fcp->txn_client_get ("freenet:CHK....")
520 ->userdata ("ehrm")
521 ->cb(sub {
522 my $data = shift->result;
523 });
524
525=cut
526
527sub cb($$) {
528 my ($self, $cb) = @_;
529 $self->{cb} = $cb;
530 $self;
531}
532
533=item $txn = $txn->userdata ([$userdata])
534
535Set user-specific data. This is useful in progress callbacks. The data can be accessed
536using C<< $txn->{userdata} >>.
537
538Returns the txn object, useful for chaining.
539
540=cut
541
542sub userdata($$) {
543 my ($self, $data) = @_;
544 $self->{userdata} = $data;
545 $self;
546}
547
548=item $txn->cancel (%attr)
549
550Cancels the operation with a C<cancel> exception anf the given attributes
551(consider at least giving the attribute C<reason>).
552
553UNTESTED.
554
555=cut
556
557sub cancel {
558 my ($self, %attr) = @_;
559 $self->throw (Net::FCP::Exception->new (cancel => { %attr }));
560 $self->set_result;
561 $self->eof;
562}
563
412sub fh_ready { 564sub fh_ready_w {
565 my ($self) = @_;
566
567 my $len = syswrite $self->{fh}, $self->{sbuf};
568
569 if ($len > 0) {
570 substr $self->{sbuf}, 0, $len, "";
571 unless (length $self->{sbuf}) {
572 fcntl $self->{fh}, F_SETFL, 0;
573 $self->{w}->cb(sub { $self->fh_ready_r })->poll (1, 0, 1);
574 }
575 } elsif (defined $len) {
576 $self->throw (Net::FCP::Exception->new (network_error => { reason => "unexpected end of file while writing" }));
577 } else {
578 $self->throw (Net::FCP::Exception->new (network_error => { reason => "$!" }));
579 }
580}
581
582sub fh_ready_r {
413 my ($self) = @_; 583 my ($self) = @_;
414 584
415 if (sysread $self->{fh}, $self->{buf}, 65536, length $self->{buf}) { 585 if (sysread $self->{fh}, $self->{buf}, 65536, length $self->{buf}) {
416 for (;;) { 586 for (;;) {
417 if ($self->{datalen}) { 587 if ($self->{datalen}) {
588 #warn "expecting new datachunk $self->{datalen}, got ".(length $self->{buf})."\n";#d#
418 if (length $self->{buf} >= $self->{datalen}) { 589 if (length $self->{buf} >= $self->{datalen}) {
419 $self->rcv_data (substr $self->{buf}, 0, $self->{datalen}, ""); 590 $self->rcv_data (substr $self->{buf}, 0, delete $self->{datalen}, "");
420 } else { 591 } else {
421 last; 592 last;
422 } 593 }
423 } elsif ($self->{buf} =~ s/^DataChunk\015?\012Length=([0-9a-fA-F]+)\015?\012Data\015?\012//) { 594 } elsif ($self->{buf} =~ s/^DataChunk\015?\012Length=([0-9a-fA-F]+)\015?\012Data\015?\012//) {
424 $self->{datalen} = hex $1; 595 $self->{datalen} = hex $1;
596 #warn "expecting new datachunk $self->{datalen}\n";#d#
425 } elsif ($self->{buf} =~ s/^([a-zA-Z]+)\015?\012(?:(.+?)\015?\012)?EndMessage\015?\012//s) { 597 } elsif ($self->{buf} =~ s/^([a-zA-Z]+)\015?\012(?:(.+?)\015?\012)?EndMessage\015?\012//s) {
426 $self->rcv ($1, { 598 $self->rcv ($1, {
427 map { my ($a, $b) = split /=/, $_, 2; ((Net::FCP::tolc $a), $b) } 599 map { my ($a, $b) = split /=/, $_, 2; ((Net::FCP::tolc $a), $b) }
428 split /\015?\012/, $2 600 split /\015?\012/, $2
429 }); 601 });
430 } else { 602 } else {
431 last; 603 last;
432 } 604 }
433 } 605 }
434 } else { 606 } else {
435 $Net::FCP::unregcb->($self);
436 delete $self->{fh};
437 $self->eof; 607 $self->eof;
438 } 608 }
439}
440
441sub rcv_data {
442 my ($self, $chunk) = @_;
443
444 $self->{data} .= $chunk;
445} 609}
446 610
447sub rcv { 611sub rcv {
448 my ($self, $type, $attr) = @_; 612 my ($self, $type, $attr) = @_;
449 613
… …
456 } else { 620 } else {
457 warn "received unexpected reply type '$type' for '$self->{type}', ignoring\n"; 621 warn "received unexpected reply type '$type' for '$self->{type}', ignoring\n";
458 } 622 }
459} 623}
460 624
625# used as a default exception thrower
626sub rcv_throw_exception {
627 my ($self, $attr, $type) = @_;
628 $self->throw (Net::FCP::Exception->new ($type, $attr));
629}
630
631*rcv_failed = \&Net::FCP::Txn::rcv_throw_exception;
632*rcv_format_error = \&Net::FCP::Txn::rcv_throw_exception;
633
634sub throw {
635 my ($self, $exc) = @_;
636
637 $self->{exception} = $exc;
638 $self->set_result;
639 $self->eof; # must be last to avoid loops
640}
641
461sub set_result { 642sub set_result {
462 my ($self, $result) = @_; 643 my ($self, $result) = @_;
463 644
464 $self->{result} = $result unless exists $self->{result}; 645 unless (exists $self->{result}) {
646 $self->{result} = $result;
647 $self->{cb}->($self) if exists $self->{cb};
648 $self->{signal}->send;
649 }
465} 650}
466 651
467sub eof { 652sub eof {
468 my ($self) = @_; 653 my ($self) = @_;
469 $self->set_result; 654
655 delete $self->{w};
656 delete $self->{fh};
657
658 delete $self->{fcp}{txn}{$self};
659
660 unless (exists $self->{result}) {
661 $self->throw (Net::FCP::Exception->new (short_data => {
662 reason => "unexpected eof or internal node error",
663 }));
664 }
665}
666
667sub progress {
668 my ($self, $type, $attr) = @_;
669 $self->{fcp}->progress ($self, $type, $attr);
470} 670}
471 671
472=item $result = $txn->result 672=item $result = $txn->result
473 673
474Waits until a result is available and then returns it. 674Waits until a result is available and then returns it.
… …
479=cut 679=cut
480 680
481sub result { 681sub result {
482 my ($self) = @_; 682 my ($self) = @_;
483 683
484 $Net::FCP::waitcb->() while !exists $self->{result}; 684 $self->{signal}->wait while !exists $self->{result};
685
686 die $self->{exception} if $self->{exception};
485 687
486 return $self->{result}; 688 return $self->{result};
487}
488
489sub DESTROY {
490 $Net::FCP::unregcb->($_[0]);
491} 689}
492 690
493package Net::FCP::Txn::ClientHello; 691package Net::FCP::Txn::ClientHello;
494 692
495use base Net::FCP::Txn; 693use base Net::FCP::Txn;
… …
524 722
525use base Net::FCP::Txn; 723use base Net::FCP::Txn;
526 724
527sub rcv_success { 725sub rcv_success {
528 my ($self, $attr) = @_; 726 my ($self, $attr) = @_;
529
530 $self->set_result ([$attr->{PublicKey}, $attr->{PrivateKey}]); 727 $self->set_result ([$attr->{PublicKey}, $attr->{PrivateKey}]);
531} 728}
532 729
533package Net::FCP::Txn::InvertPrivateKey; 730package Net::FCP::Txn::InsertPrivateKey;
534 731
535use base Net::FCP::Txn; 732use base Net::FCP::Txn;
536 733
537sub rcv_success { 734sub rcv_success {
538 my ($self, $attr) = @_; 735 my ($self, $attr) = @_;
539
540 $self->set_result ($attr->{PublicKey}); 736 $self->set_result ($attr->{PublicKey});
541} 737}
542 738
543package Net::FCP::Txn::GetSize; 739package Net::FCP::Txn::GetSize;
544 740
545use base Net::FCP::Txn; 741use base Net::FCP::Txn;
546 742
547sub rcv_success { 743sub rcv_success {
548 my ($self, $attr) = @_; 744 my ($self, $attr) = @_;
549
550 $self->set_result ($attr->{Length}); 745 $self->set_result ($attr->{Length});
551} 746}
552 747
748package Net::FCP::Txn::GetPut;
749
750# base class for get and put
751
752use base Net::FCP::Txn;
753
754*rcv_uri_error = \&Net::FCP::Txn::rcv_throw_exception;
755*rcv_route_not_found = \&Net::FCP::Txn::rcv_throw_exception;
756
757sub rcv_restarted {
758 my ($self, $attr, $type) = @_;
759
760 delete $self->{datalength};
761 delete $self->{metalength};
762 delete $self->{data};
763
764 $self->progress ($type, $attr);
765}
766
553package Net::FCP::Txn::ClientGet; 767package Net::FCP::Txn::ClientGet;
554 768
555use base Net::FCP::Txn; 769use base Net::FCP::Txn::GetPut;
770
771*rcv_data_not_found = \&Net::FCP::Txn::rcv_throw_exception;
772
773sub rcv_data {
774 my ($self, $chunk) = @_;
775
776 $self->{data} .= $chunk;
777
778 $self->progress ("data", { chunk => length $chunk, received => length $self->{data}, total => $self->{datalength} });
779
780 if ($self->{datalength} == length $self->{data}) {
781 my $data = delete $self->{data};
782 my $meta = Net::FCP::parse_metadata substr $data, 0, $self->{metalength}, "";
783
784 $self->set_result ([$meta, $data]);
785 }
786}
556 787
557sub rcv_data_found { 788sub rcv_data_found {
558 my ($self, $attr) = @_; 789 my ($self, $attr, $type) = @_;
790
791 $self->progress ($type, $attr);
559 792
560 $self->{datalength} = hex $attr->{data_length}; 793 $self->{datalength} = hex $attr->{data_length};
561 $self->{metalength} = hex $attr->{metadata_length}; 794 $self->{metalength} = hex $attr->{metadata_length};
562} 795}
563 796
564sub rcv_restarted { 797package Net::FCP::Txn::ClientPut;
565 # nop, maybe feedback
566}
567 798
799use base Net::FCP::Txn::GetPut;
800
801*rcv_size_error = \&Net::FCP::Txn::rcv_throw_exception;
802*rcv_key_collision = \&Net::FCP::Txn::rcv_throw_exception;
803
804sub rcv_pending {
805 my ($self, $attr, $type) = @_;
806 $self->progress ($type, $attr);
807}
808
809sub rcv_success {
810 my ($self, $attr, $type) = @_;
811 $self->set_result ($attr);
812}
813
814=back
815
816=head2 The Net::FCP::Exception CLASS
817
818Any unexpected (non-standard) responses that make it impossible to return
819the advertised result will result in an exception being thrown when the
820C<result> method is called.
821
822These exceptions are represented by objects of this class.
823
824=over 4
825
826=cut
827
828package Net::FCP::Exception;
829
830use overload
831 '""' => sub {
832 "Net::FCP::Exception<<$_[0][0]," . (join ":", %{$_[0][1]}) . ">>\n";
833 };
834
835=item $exc = new Net::FCP::Exception $type, \%attr
836
837Create a new exception object of the given type (a string like
838C<route_not_found>), and a hashref containing additional attributes
839(usually the attributes of the message causing the exception).
840
841=cut
842
568sub eof { 843sub new {
844 my ($class, $type, $attr) = @_;
845
846 bless [Net::FCP::tolc $type, { %$attr }], $class;
847}
848
849=item $exc->type([$type])
850
851With no arguments, returns the exception type. Otherwise a boolean
852indicating wether the exception is of the given type is returned.
853
854=cut
855
856sub type {
569 my ($self) = @_; 857 my ($self, $type) = @_;
570 858
571 my $data = delete $self->{data}; 859 @_ >= 2
572 my $meta = Net::FCP::parse_metadata substr $data, 0, $self->{metalength}, ""; 860 ? $self->[0] eq $type
861 : $self->[0];
862}
573 863
574 $self->set_result ([$meta, $data]); 864=item $exc->attr([$attr])
865
866With no arguments, returns the attributes. Otherwise the named attribute
867value is returned.
868
869=cut
870
871sub attr {
872 my ($self, $attr) = @_;
873
874 @_ >= 2
875 ? $self->[1]{$attr}
876 : $self->[1];
575} 877}
576 878
577=back 879=back
578 880
579=head1 SEE ALSO 881=head1 SEE ALSO

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines