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

Comparing cvsroot/Net-FCP/FCP.pm (file contents):
Revision 1.10 by root, Tue Sep 9 06:22:58 2003 UTC vs.
Revision 1.20 by root, Mon Sep 15 00:05:32 2003 UTC

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

Diff Legend

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