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.9 by root, Tue Sep 9 06:13:18 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.04; 77$VERSION = 0.08;
78
79no warnings;
52 80
53our $EVENT = Net::FCP::Event::Auto::; 81our $EVENT = Net::FCP::Event::Auto::;
54$EVENT = Net::FCP::Event::Event::;#d#
55 82
56sub import { 83sub import {
57 shift; 84 shift;
58 85
59 for (@_) { 86 for (@_) {
60 if (/^event=(\w+)$/) { 87 if (/^event=(\w+)$/) {
61 $EVENT = "Net::FCP::Event::$1"; 88 $EVENT = "Net::FCP::Event::$1";
89 eval "require $EVENT";
62 } 90 }
63 } 91 }
64 eval "require $EVENT"; 92 die $@ if $@;
65} 93}
66 94
67sub touc($) { 95sub touc($) {
68 local $_ = shift; 96 local $_ = shift;
69 1 while s/((?:^|_)(?:svk|chk|uri)(?:_|$))/\U$1/; 97 1 while s/((?:^|_)(?:svk|chk|uri)(?:_|$))/\U$1/;
… …
91 119
92 ( 120 (
93 version => { revision => 1 }, 121 version => { revision => 1 },
94 document => [ 122 document => [
95 { 123 {
96 "info.format" => "image/jpeg", 124 info => { format" => "image/jpeg" },
97 name => "background.jpg", 125 name => "background.jpg",
98 "redirect.target" => "freenet:CHK\@ZcagI,ra726bSw" 126 redirect => { target => "freenet:CHK\@ZcagI,ra726bSw" },
99 }, 127 },
100 { 128 {
101 "info.format" => "text/html", 129 info => { format" => "text/html" },
102 name => ".next", 130 name => ".next",
103 "redirect.target" => "freenet:SSK\@ilUPAgM/TFEE/3" 131 redirect => { target => "freenet:SSK\@ilUPAgM/TFEE/3" },
104 }, 132 },
105 { 133 {
106 "info.format" => "text/html", 134 info => { format" => "text/html" },
107 "redirect.target" => "freenet:CHK\@8M8Po8ucwI,8xA" 135 redirect => { target => "freenet:CHK\@8M8Po8ucwI,8xA" },
108 } 136 }
109 ] 137 ]
110 ) 138 )
111 139
112=cut 140=cut
… …
119 my $hdr = $meta->{version} = {}; 147 my $hdr = $meta->{version} = {};
120 148
121 for (;;) { 149 for (;;) {
122 while ($data =~ /\G([^=\015\012]+)=([^\015\012]*)\015?\012/gc) { 150 while ($data =~ /\G([^=\015\012]+)=([^\015\012]*)\015?\012/gc) {
123 my ($k, $v) = ($1, $2); 151 my ($k, $v) = ($1, $2);
124 $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;
125 } 158 }
126 159
127 if ($data =~ /\GEndPart\015?\012/gc) { 160 if ($data =~ /\GEndPart\015?\012/gc) {
161 # nop
128 } elsif ($data =~ /\GEnd\015?\012/gc) { 162 } elsif ($data =~ /\GEnd(\015?\012|$)/gc) {
129 last; 163 last;
130 } elsif ($data =~ /\G([A-Za-z0-9.\-]+)\015?\012/gcs) { 164 } elsif ($data =~ /\G([A-Za-z0-9.\-]+)\015?\012/gcs) {
131 push @{$meta->{tolc $1}}, $hdr = {}; 165 push @{$meta->{tolc $1}}, $hdr = {};
132 } elsif ($data =~ /\G(.*)/gcs) { 166 } elsif ($data =~ /\G(.*)/gcs) {
167 print STDERR "metadata format error ($1), please report this string: <<$data>>";
133 die "metadata format error ($1)"; 168 die "metadata format error";
134 } 169 }
135 } 170 }
136 } 171 }
137 172
138 #$meta->{tail} = substr $data, pos $data; 173 #$meta->{tail} = substr $data, pos $data;
… …
144 179
145Create 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
146127.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>).
147 182
148Connections are virtual because no persistent physical connection is 183Connections are virtual because no persistent physical connection is
184established.
185
186=begin comment
187
149established. However, the existance of the node is checked by executing a 188However, the existance of the node is checked by executing a
150C<ClientHello> transaction. 189C<ClientHello> transaction.
190
191=end
151 192
152=cut 193=cut
153 194
154sub new { 195sub new {
155 my $class = shift; 196 my $class = shift;
156 my $self = bless { @_ }, $class; 197 my $self = bless { @_ }, $class;
157 198
158 $self->{host} ||= $ENV{FREDHOST} || "127.0.0.1"; 199 $self->{host} ||= $ENV{FREDHOST} || "127.0.0.1";
159 $self->{port} ||= $ENV{FREDPORt} || 8481; 200 $self->{port} ||= $ENV{FREDPORT} || 8481;
160 201
161 $self->{nodehello} = $self->client_hello 202 #$self->{nodehello} = $self->client_hello
162 or croak "unable to get nodehello from node\n"; 203 # or croak "unable to get nodehello from node\n";
163 204
164 $self; 205 $self;
165} 206}
166 207
167sub progress { 208sub progress {
168 my ($self, $txn, $type, $attr) = @_; 209 my ($self, $txn, $type, $attr) = @_;
169 warn "progress<$txn,$type," . (join ":", %$attr) . ">\n"; 210 #warn "progress<$txn,$type," . (join ":", %$attr) . ">\n";
170} 211}
171 212
172=item $txn = $fcp->txn(type => attr => val,...) 213=item $txn = $fcp->txn(type => attr => val,...)
173 214
174The 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 );
175 238
176=cut 239=cut
177 240
178sub txn { 241sub txn {
179 my ($self, $type, %attr) = @_; 242 my ($self, $type, %attr) = @_;
… …
183 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);
184 247
185 $txn; 248 $txn;
186} 249}
187 250
188sub _txn($&) { 251{ # transactions
252
253my $txn = sub {
189 my ($name, $sub) = @_; 254 my ($name, $sub) = @_;
190 *{"$name\_txn"} = $sub; 255 *{"txn_$name"} = $sub;
191 *{$name} = sub { $sub->(@_)->result }; 256 *{$name} = sub { $sub->(@_)->result };
192} 257};
193 258
194=item $txn = $fcp->txn_client_hello 259=item $txn = $fcp->txn_client_hello
195 260
196=item $nodehello = $fcp->client_hello 261=item $nodehello = $fcp->client_hello
197 262
… …
203 protocol => "1.2", 268 protocol => "1.2",
204 } 269 }
205 270
206=cut 271=cut
207 272
208_txn client_hello => sub { 273$txn->(client_hello => sub {
209 my ($self) = @_; 274 my ($self) = @_;
210 275
211 $self->txn ("client_hello"); 276 $self->txn ("client_hello");
212}; 277});
213 278
214=item $txn = $fcp->txn_client_info 279=item $txn = $fcp->txn_client_info
215 280
216=item $nodeinfo = $fcp->client_info 281=item $nodeinfo = $fcp->client_info
217 282
… …
241 routing_time => "a5", 306 routing_time => "a5",
242 } 307 }
243 308
244=cut 309=cut
245 310
246_txn client_info => sub { 311$txn->(client_info => sub {
247 my ($self) = @_; 312 my ($self) = @_;
248 313
249 $self->txn ("client_info"); 314 $self->txn ("client_info");
250}; 315});
251 316
252=item $txn = $fcp->txn_generate_chk ($metadata, $data) 317=item $txn = $fcp->txn_generate_chk ($metadata, $data)
253 318
254=item $uri = $fcp->generate_chk ($metadata, $data) 319=item $uri = $fcp->generate_chk ($metadata, $data)
255 320
256Creates a new CHK, given the metadata and data. UNTESTED. 321Creates a new CHK, given the metadata and data. UNTESTED.
257 322
258=cut 323=cut
259 324
260_txn generate_chk => sub { 325$txn->(generate_chk => sub {
261 my ($self, $metadata, $data) = @_; 326 my ($self, $metadata, $data) = @_;
262 327
263 $self->txn (generate_chk => data => "$data$metadata", metadata_length => length $metadata); 328 $self->txn (generate_chk => data => "$metadata$data", metadata_length => length $metadata);
264}; 329});
265 330
266=item $txn = $fcp->txn_generate_svk_pair 331=item $txn = $fcp->txn_generate_svk_pair
267 332
268=item ($public, $private) = @{ $fcp->generate_svk_pair } 333=item ($public, $private) = @{ $fcp->generate_svk_pair }
269 334
… …
274 "ZnmvMITaTXBMFGl4~jrjuyWxOWg" 339 "ZnmvMITaTXBMFGl4~jrjuyWxOWg"
275 ] 340 ]
276 341
277=cut 342=cut
278 343
279_txn generate_svk_pair => sub { 344$txn->(generate_svk_pair => sub {
280 my ($self) = @_; 345 my ($self) = @_;
281 346
282 $self->txn ("generate_svk_pair"); 347 $self->txn ("generate_svk_pair");
283}; 348});
284 349
285=item $txn = $fcp->txn_insert_private_key ($private) 350=item $txn = $fcp->txn_insert_private_key ($private)
286 351
287=item $uri = $fcp->insert_private_key ($private) 352=item $public = $fcp->insert_private_key ($private)
288 353
289Inserts 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
290with 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
291from C<generate_svk_pair>). 356back from C<generate_svk_pair>).
292 357
293Returns the public key. 358Returns the public key.
294 359
295UNTESTED. 360UNTESTED.
296 361
297=cut 362=cut
298 363
299_txn insert_private_key => sub { 364$txn->(insert_private_key => sub {
300 my ($self, $privkey) = @_; 365 my ($self, $privkey) = @_;
301 366
302 $self->txn (invert_private_key => private => $privkey); 367 $self->txn (invert_private_key => private => $privkey);
303}; 368});
304 369
305=item $txn = $fcp->txn_get_size ($uri) 370=item $txn = $fcp->txn_get_size ($uri)
306 371
307=item $length = $fcp->get_size ($uri) 372=item $length = $fcp->get_size ($uri)
308 373
… …
311 376
312UNTESTED. 377UNTESTED.
313 378
314=cut 379=cut
315 380
316_txn get_size => sub { 381$txn->(get_size => sub {
317 my ($self, $uri) = @_; 382 my ($self, $uri) = @_;
318 383
319 $self->txn (get_size => URI => $uri); 384 $self->txn (get_size => URI => $uri);
320}; 385});
321 386
322=item $txn = $fcp->txn_client_get ($uri [, $htl = 15 [, $removelocal = 0]]) 387=item $txn = $fcp->txn_client_get ($uri [, $htl = 15 [, $removelocal = 0]])
323 388
324=item ($metadata, $data) = @{ $fcp->client_get ($uri, $htl, $removelocal) 389=item ($metadata, $data) = @{ $fcp->client_get ($uri, $htl, $removelocal)
325 390
… …
335 ) 400 )
336 }; 401 };
337 402
338=cut 403=cut
339 404
340_txn client_get => sub { 405$txn->(client_get => sub {
341 my ($self, $uri, $htl, $removelocal) = @_; 406 my ($self, $uri, $htl, $removelocal) = @_;
342 407
343 $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");
344}; 410});
345 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
346=item MISSING: ClientPut 436=item MISSING: (ClientPut), InsretKey
347 437
348=back 438=back
349 439
350=head2 THE Net::FCP::Txn CLASS 440=head2 THE Net::FCP::Txn CLASS
351 441
… …
362 452
363=cut 453=cut
364 454
365package Net::FCP::Txn; 455package Net::FCP::Txn;
366 456
457use Fcntl;
458use Socket;
459
367=item new arg => val,... 460=item new arg => val,...
368 461
369Creates a new C<Net::FCP::Txn> object. Not normally used. 462Creates a new C<Net::FCP::Txn> object. Not normally used.
370 463
371=cut 464=cut
372 465
373sub new { 466sub new {
374 my $class = shift; 467 my $class = shift;
375 my $self = bless { @_ }, $class; 468 my $self = bless { @_ }, $class;
469
470 $self->{signal} = $EVENT->new_signal;
471
472 $self->{fcp}{txn}{$self} = $self;
376 473
377 my $attr = ""; 474 my $attr = "";
378 my $data = delete $self->{attr}{data}; 475 my $data = delete $self->{attr}{data};
379 476
380 while (my ($k, $v) = each %{$self->{attr}}) { 477 while (my ($k, $v) = each %{$self->{attr}}) {
… …
386 $data = "Data\012$data"; 483 $data = "Data\012$data";
387 } else { 484 } else {
388 $data = "EndMessage\012"; 485 $data = "EndMessage\012";
389 } 486 }
390 487
391 my $fh = new IO::Socket::INET 488 socket my $fh, PF_INET, SOCK_STREAM, 0
392 PeerHost => $self->{fcp}{host}, 489 or Carp::croak "unable to create new tcp socket: $!";
393 PeerPort => $self->{fcp}{port}
394 or Carp::croak "FCP::txn: unable to connect to $self->{fcp}{host}:$self->{fcp}{port}: $!\n";
395
396 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";
397 496
398 if (0) { 497 $self->{sbuf} =
399 print 498 "\x00\x00\x00\x02"
400 Net::FCP::touc $self->{type}, "\012",
401 $attr,
402 $data, "\012";
403 }
404
405 print $fh
406 "\x00\x00", "\x00\x02", # SESSID, PRESID
407 Net::FCP::touc $self->{type}, "\012", 499 . Net::FCP::touc $self->{type}
408 $attr, 500 . "\012$attr$data";
409 $data;
410 501
411 #$fh->shutdown (1); # freenet buggy?, well, it's java... 502 #$fh->shutdown (1); # freenet buggy?, well, it's java...
412 503
413 $self->{fh} = $fh; 504 $self->{fh} = $fh;
414 505
415 $EVENT->reg_r_cb ($self); 506 $self->{w} = $EVENT->new_from_fh ($fh)->cb(sub { $self->fh_ready_w })->poll(0, 1, 1);
416 507
417 $self; 508 $self;
418} 509}
419 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
420=item $userdata = $txn->userdata ([$userdata]) 535=item $txn = $txn->userdata ([$userdata])
421 536
422Get 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} >>.
423 539
424=cut 540Returns the txn object, useful for chaining.
425 541
542=cut
543
426sub userdata($;$) { 544sub userdata($$) {
427 my ($self, $data) = @_; 545 my ($self, $data) = @_;
428 $self->{userdata} = $data if @_ >= 2; 546 $self->{userdata} = $data;
429 $self->{userdata}; 547 $self;
430} 548}
431 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
432sub 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 {
433 my ($self) = @_; 585 my ($self) = @_;
434 586
435 if (sysread $self->{fh}, $self->{buf}, 65536, length $self->{buf}) { 587 if (sysread $self->{fh}, $self->{buf}, 65536, length $self->{buf}) {
436 for (;;) { 588 for (;;) {
437 if ($self->{datalen}) { 589 if ($self->{datalen}) {
590 #warn "expecting new datachunk $self->{datalen}, got ".(length $self->{buf})."\n";#d#
438 if (length $self->{buf} >= $self->{datalen}) { 591 if (length $self->{buf} >= $self->{datalen}) {
439 $self->rcv_data (substr $self->{buf}, 0, $self->{datalen}, ""); 592 $self->rcv_data (substr $self->{buf}, 0, delete $self->{datalen}, "");
440 } else { 593 } else {
441 last; 594 last;
442 } 595 }
443 } 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//) {
444 $self->{datalen} = hex $1; 597 $self->{datalen} = hex $1;
598 #warn "expecting new datachunk $self->{datalen}\n";#d#
445 } 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) {
446 $self->rcv ($1, { 600 $self->rcv ($1, {
447 map { my ($a, $b) = split /=/, $_, 2; ((Net::FCP::tolc $a), $b) } 601 map { my ($a, $b) = split /=/, $_, 2; ((Net::FCP::tolc $a), $b) }
448 split /\015?\012/, $2 602 split /\015?\012/, $2
449 }); 603 });
450 } else { 604 } else {
451 last; 605 last;
452 } 606 }
453 } 607 }
454 } else { 608 } else {
455 $EVENT->unreg_r_cb ($self);
456 delete $self->{fh};
457 $self->eof; 609 $self->eof;
458 } 610 }
459}
460
461sub rcv_data {
462 my ($self, $chunk) = @_;
463
464 $self->{data} .= $chunk;
465
466 $self->progress ("data", { chunk => length $chunk, total => length $self->{data}, end => $self->{datalength} });
467} 611}
468 612
469sub rcv { 613sub rcv {
470 my ($self, $type, $attr) = @_; 614 my ($self, $type, $attr) = @_;
471 615
… …
478 } else { 622 } else {
479 warn "received unexpected reply type '$type' for '$self->{type}', ignoring\n"; 623 warn "received unexpected reply type '$type' for '$self->{type}', ignoring\n";
480 } 624 }
481} 625}
482 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
483sub throw { 636sub throw {
484 my ($self, $exc) = @_; 637 my ($self, $exc) = @_;
485 638
486 $self->{exception} = $exc; 639 $self->{exception} = $exc;
487 $self->set_result (1); 640 $self->set_result;
641 $self->eof; # must be last to avoid loops
488} 642}
489 643
490sub set_result { 644sub set_result {
491 my ($self, $result) = @_; 645 my ($self, $result) = @_;
492 646
493 $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 }
494} 652}
495 653
496sub eof { 654sub eof {
497 my ($self) = @_; 655 my ($self) = @_;
498 $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 }
499} 667}
500 668
501sub progress { 669sub progress {
502 my ($self, $type, $attr) = @_; 670 my ($self, $type, $attr) = @_;
503 $self->{fcp}->progress ($self, $type, $attr); 671 $self->{fcp}->progress ($self, $type, $attr);
… …
513=cut 681=cut
514 682
515sub result { 683sub result {
516 my ($self) = @_; 684 my ($self) = @_;
517 685
518 $EVENT->wait_event while !exists $self->{result}; 686 $self->{signal}->wait while !exists $self->{result};
519 687
520 die $self->{exception} if $self->{exception}; 688 die $self->{exception} if $self->{exception};
521 689
522 return $self->{result}; 690 return $self->{result};
523}
524
525sub DESTROY {
526 $EVENT->unreg_r_cb ($_[0]);
527 #$EVENT->unreg_w_cb ($_[0]);
528} 691}
529 692
530package Net::FCP::Txn::ClientHello; 693package Net::FCP::Txn::ClientHello;
531 694
532use base Net::FCP::Txn; 695use base Net::FCP::Txn;
… …
561 724
562use base Net::FCP::Txn; 725use base Net::FCP::Txn;
563 726
564sub rcv_success { 727sub rcv_success {
565 my ($self, $attr) = @_; 728 my ($self, $attr) = @_;
566
567 $self->set_result ([$attr->{PublicKey}, $attr->{PrivateKey}]); 729 $self->set_result ([$attr->{PublicKey}, $attr->{PrivateKey}]);
568} 730}
569 731
570package Net::FCP::Txn::InvertPrivateKey; 732package Net::FCP::Txn::InsertPrivateKey;
571 733
572use base Net::FCP::Txn; 734use base Net::FCP::Txn;
573 735
574sub rcv_success { 736sub rcv_success {
575 my ($self, $attr) = @_; 737 my ($self, $attr) = @_;
576
577 $self->set_result ($attr->{PublicKey}); 738 $self->set_result ($attr->{PublicKey});
578} 739}
579 740
580package Net::FCP::Txn::GetSize; 741package Net::FCP::Txn::GetSize;
581 742
582use base Net::FCP::Txn; 743use base Net::FCP::Txn;
583 744
584sub rcv_success { 745sub rcv_success {
585 my ($self, $attr) = @_; 746 my ($self, $attr) = @_;
586
587 $self->set_result ($attr->{Length}); 747 $self->set_result ($attr->{Length});
588} 748}
589 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
590package Net::FCP::Txn::ClientGet; 769package Net::FCP::Txn::ClientGet;
591 770
592use 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}
593 789
594sub rcv_data_found { 790sub rcv_data_found {
595 my ($self, $attr, $type) = @_; 791 my ($self, $attr, $type) = @_;
596 792
597 $self->progress ($type, $attr); 793 $self->progress ($type, $attr);
598 794
599 $self->{datalength} = hex $attr->{data_length}; 795 $self->{datalength} = hex $attr->{data_length};
600 $self->{metalength} = hex $attr->{metadata_length}; 796 $self->{metalength} = hex $attr->{metadata_length};
601} 797}
602 798
603sub rcv_route_not_found { 799package Net::FCP::Txn::ClientPut;
604 my ($self, $attr, $type) = @_;
605 800
606 $self->throw (new Net::FCP::Exception $type, $attr); 801use base Net::FCP::Txn::GetPut;
607}
608 802
609sub rcv_data_not_found { 803*rcv_size_error = \&Net::FCP::Txn::rcv_throw_exception;
610 my ($self, $attr, $type) = @_; 804*rcv_key_collision = \&Net::FCP::Txn::rcv_throw_exception;
611 805
612 $self->throw (new Net::FCP::Exception $type, $attr); 806sub rcv_pending {
613}
614
615sub rcv_format_error {
616 my ($self, $attr, $type) = @_;
617
618 $self->throw (new Net::FCP::Exception $type, $attr);
619}
620
621sub rcv_restarted {
622 my ($self, $attr, $type) = @_; 807 my ($self, $attr, $type) = @_;
623 $self->progress ($type, $attr); 808 $self->progress ($type, $attr);
624} 809}
625 810
626sub eof { 811sub rcv_success {
627 my ($self) = @_; 812 my ($self, $attr, $type) = @_;
628
629 my $data = delete $self->{data};
630 my $meta = Net::FCP::parse_metadata substr $data, 0, $self->{metalength}, "";
631
632 $self->set_result ([$meta, $data]); 813 $self->set_result ($attr);
633} 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
634 829
635package Net::FCP::Exception; 830package Net::FCP::Exception;
636 831
637use overload 832use overload
638 '""' => sub { 833 '""' => sub {
639 "Net::FCP::Exception<<$_[0][0]," . (join ":", %{$_[0][1]}) . ">>\n"; 834 "Net::FCP::Exception<<$_[0][0]," . (join ":", %{$_[0][1]}) . ">>\n";
640 }; 835 };
641 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
642sub new { 845sub new {
643 my ($class, $type, $attr) = @_; 846 my ($class, $type, $attr) = @_;
644 847
645 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];
646} 879}
647 880
648=back 881=back
649 882
650=head1 SEE ALSO 883=head1 SEE ALSO
… …
658 Marc Lehmann <pcg@goof.com> 891 Marc Lehmann <pcg@goof.com>
659 http://www.goof.com/pcg/marc/ 892 http://www.goof.com/pcg/marc/
660 893
661=cut 894=cut
662 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
6631; 9281;
664 929

Diff Legend

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