ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Net-FCP/FCP.pm
Revision: 1.27
Committed: Thu May 13 15:41:01 2004 UTC (20 years ago) by root
Branch: MAIN
Changes since 1.26: +26 -7 lines
Log Message:
*** empty log message ***

File Contents

# Content
1 =head1 NAME
2
3 Net::FCP - http://freenet.sf.net client protocol
4
5 =head1 SYNOPSIS
6
7 use Net::FCP;
8
9 my $fcp = new Net::FCP;
10
11 my $ni = $fcp->txn_node_info->result;
12 my $ni = $fcp->node_info;
13
14 =head1 DESCRIPTION
15
16 See L<http://freenet.sourceforge.net/index.php?page=fcp> for a description
17 of what the messages do. I am too lazy to document all this here.
18
19 =head1 WARNING
20
21 This module is alpha. While it probably won't destroy (much :) of your
22 data, it currently falls short of what it should provide (intelligent uri
23 following, splitfile downloads, healing...)
24
25 =head2 IMPORT TAGS
26
27 Nothing much can be "imported" from this module right now. There are,
28 however, certain "import tags" that can be used to select the event model
29 to be used.
30
31 Event models are implemented as modules under the C<Net::FCP::Event::xyz>
32 class, where C<xyz> is the event model to use. The default is C<Event> (or
33 later C<Auto>).
34
35 The import tag to use is named C<event=xyz>, e.g. C<event=Event>,
36 C<event=Glib> etc.
37
38 You should specify the event module to use only in the main program.
39
40 If no event model has been specified, FCP tries to autodetect it on first
41 use (e.g. first transaction), in this order: Coro, Event, Glib, Tk.
42
43 =head2 FREENET BASICS
44
45 Ok, this section will not explain any freenet basics to you, just some
46 problems I found that you might want to avoid:
47
48 =over 4
49
50 =item freenet URIs are _NOT_ URIs
51
52 Whenever a "uri" is required by the protocol, freenet expects a kind of
53 URI prefixed with the "freenet:" scheme, e.g. "freenet:CHK...". However,
54 these are not URIs, as freeent fails to parse them correctly, that is, you
55 must unescape an escaped characters ("%2c" => ",") yourself. Maybe in the
56 future this library will do it for you, so watch out for this incompatible
57 change.
58
59 =item Numbers are in HEX
60
61 Virtually every number in the FCP protocol is in hex. Be sure to use
62 C<hex()> on all such numbers, as the module (currently) does nothing to
63 convert these for you.
64
65 =back
66
67 =head2 THE Net::FCP CLASS
68
69 =over 4
70
71 =cut
72
73 package Net::FCP;
74
75 use Carp;
76
77 $VERSION = 0.6;
78
79 no warnings;
80
81 our $EVENT = Net::FCP::Event::Auto::;
82
83 sub import {
84 shift;
85
86 for (@_) {
87 if (/^event=(\w+)$/) {
88 $EVENT = "Net::FCP::Event::$1";
89 eval "require $EVENT";
90 }
91 }
92 die $@ if $@;
93 }
94
95 sub touc($) {
96 local $_ = shift;
97 1 while s/((?:^|_)(?:svk|chk|uri)(?:_|$))/\U$1/;
98 s/(?:^|_)(.)/\U$1/g;
99 $_;
100 }
101
102 sub tolc($) {
103 local $_ = shift;
104 1 while s/(SVK|CHK|URI)([^_])/$1\_$2/i;
105 1 while s/([^_])(SVK|CHK|URI)/$1\_$2/i;
106 s/(?<=[a-z])(?=[A-Z])/_/g;
107 lc $_;
108 }
109
110 # the opposite of hex
111 sub xeh($) {
112 sprintf "%x", $_[0];
113 }
114
115 =item $meta = Net::FCP::parse_metadata $string
116
117 Parse a metadata string and return it.
118
119 The metadata will be a hashref with key C<version> (containing the
120 mandatory version header entries) and key C<raw> containing the original
121 metadata string.
122
123 All other headers are represented by arrayrefs (they can be repeated).
124
125 Since this description is confusing, here is a rather verbose example of a
126 parsed manifest:
127
128 (
129 raw => "Version...",
130 version => { revision => 1 },
131 document => [
132 {
133 info => { format" => "image/jpeg" },
134 name => "background.jpg",
135 redirect => { target => "freenet:CHK\@ZcagI,ra726bSw" },
136 },
137 {
138 info => { format" => "text/html" },
139 name => ".next",
140 redirect => { target => "freenet:SSK\@ilUPAgM/TFEE/3" },
141 },
142 {
143 info => { format" => "text/html" },
144 redirect => { target => "freenet:CHK\@8M8Po8ucwI,8xA" },
145 }
146 ]
147 )
148
149 =cut
150
151 sub parse_metadata {
152 my $data = shift;
153 my $meta = { raw => $data };
154
155 if ($data =~ /^Version\015?\012/gc) {
156 my $hdr = $meta->{version} = {};
157
158 for (;;) {
159 while ($data =~ /\G([^=\015\012]+)=([^\015\012]*)\015?\012/gc) {
160 my ($k, $v) = ($1, $2);
161 my @p = split /\./, tolc $k, 3;
162
163 $hdr->{$p[0]} = $v if @p == 1; # lamest code I ever wrote
164 $hdr->{$p[0]}{$p[1]} = $v if @p == 2;
165 $hdr->{$p[0]}{$p[1]}{$p[2]} = $v if @p == 3;
166 die "FATAL: 4+ dot metadata" if @p >= 4;
167 }
168
169 if ($data =~ /\GEndPart\015?\012/gc) {
170 # nop
171 } elsif ($data =~ /\GEnd(\015?\012|$)/gc) {
172 last;
173 } elsif ($data =~ /\G([A-Za-z0-9.\-]+)\015?\012/gcs) {
174 push @{$meta->{tolc $1}}, $hdr = {};
175 } elsif ($data =~ /\G(.*)/gcs) {
176 print STDERR "metadata format error ($1), please report this string: <<$data>>";
177 die "metadata format error";
178 }
179 }
180 }
181
182 #$meta->{tail} = substr $data, pos $data;
183
184 $meta;
185 }
186
187 =item $fcp = new Net::FCP [host => $host][, port => $port][, progress => \&cb]
188
189 Create a new virtual FCP connection to the given host and port (default
190 127.0.0.1:8481, or the environment variables C<FREDHOST> and C<FREDPORT>).
191
192 Connections are virtual because no persistent physical connection is
193 established.
194
195 You can install a progress callback that is being called with the Net::FCP
196 object, a txn object, the type of the transaction and the attributes. Use
197 it like this:
198
199 sub progress_cb {
200 my ($self, $txn, $type, $attr) = @_;
201
202 warn "progress<$txn,$type," . (join ":", %$attr) . ">\n";
203 }
204
205 =begin comment
206
207 However, the existance of the node is checked by executing a
208 C<ClientHello> transaction.
209
210 =end
211
212 =cut
213
214 sub new {
215 my $class = shift;
216 my $self = bless { @_ }, $class;
217
218 $self->{host} ||= $ENV{FREDHOST} || "127.0.0.1";
219 $self->{port} ||= $ENV{FREDPORT} || 8481;
220
221 #$self->{nodehello} = $self->client_hello
222 # or croak "unable to get nodehello from node\n";
223
224 $self;
225 }
226
227 sub progress {
228 my ($self, $txn, $type, $attr) = @_;
229
230 $self->{progress}->($self, $txn, $type, $attr)
231 if $self->{progress};
232 #warn "progress<$txn,$type," . (join ":", %$attr) . ">\n";
233 }
234
235 =item $txn = $fcp->txn(type => attr => val,...)
236
237 The low-level interface to transactions. Don't use it.
238
239 Here are some examples of using transactions:
240
241 The blocking case, no (visible) transactions involved:
242
243 my $nodehello = $fcp->client_hello;
244
245 A transaction used in a blocking fashion:
246
247 my $txn = $fcp->txn_client_hello;
248 ...
249 my $nodehello = $txn->result;
250
251 Or shorter:
252
253 my $nodehello = $fcp->txn_client_hello->result;
254
255 Setting callbacks:
256
257 $fcp->txn_client_hello->cb(
258 sub { my $nodehello => $_[0]->result }
259 );
260
261 =cut
262
263 sub txn {
264 my ($self, $type, %attr) = @_;
265
266 $type = touc $type;
267
268 my $txn = "Net::FCP::Txn::$type"->new(fcp => $self, type => tolc $type, attr => \%attr);
269
270 $txn;
271 }
272
273 { # transactions
274
275 my $txn = sub {
276 my ($name, $sub) = @_;
277 *{"txn_$name"} = $sub;
278 *{$name} = sub { $sub->(@_)->result };
279 };
280
281 =item $txn = $fcp->txn_client_hello
282
283 =item $nodehello = $fcp->client_hello
284
285 Executes a ClientHello request and returns it's results.
286
287 {
288 max_file_size => "5f5e100",
289 node => "Fred,0.6,1.46,7050"
290 protocol => "1.2",
291 }
292
293 =cut
294
295 $txn->(client_hello => sub {
296 my ($self) = @_;
297
298 $self->txn ("client_hello");
299 });
300
301 =item $txn = $fcp->txn_client_info
302
303 =item $nodeinfo = $fcp->client_info
304
305 Executes a ClientInfo request and returns it's results.
306
307 {
308 active_jobs => "1f",
309 allocated_memory => "bde0000",
310 architecture => "i386",
311 available_threads => 17,
312 datastore_free => "5ce03400",
313 datastore_max => "2540be400",
314 datastore_used => "1f72bb000",
315 estimated_load => 52,
316 free_memory => "5cc0148",
317 is_transient => "false",
318 java_name => "Java HotSpot(_T_M) Server VM",
319 java_vendor => "http://www.blackdown.org/",
320 java_version => "Blackdown-1.4.1-01",
321 least_recent_timestamp => "f41538b878",
322 max_file_size => "5f5e100",
323 most_recent_timestamp => "f77e2cc520"
324 node_address => "1.2.3.4",
325 node_port => 369,
326 operating_system => "Linux",
327 operating_system_version => "2.4.20",
328 routing_time => "a5",
329 }
330
331 =cut
332
333 $txn->(client_info => sub {
334 my ($self) = @_;
335
336 $self->txn ("client_info");
337 });
338
339 =item $txn = $fcp->txn_generate_chk ($metadata, $data[, $cipher])
340
341 =item $uri = $fcp->generate_chk ($metadata, $data[, $cipher])
342
343 Calculates a CHK, given the metadata and data. C<$cipher> is either
344 C<Rijndael> or C<Twofish>, with the latter being the default.
345
346 =cut
347
348 $txn->(generate_chk => sub {
349 my ($self, $metadata, $data, $cipher) = @_;
350
351 $self->txn (generate_chk =>
352 data => "$metadata$data",
353 metadata_length => xeh length $metadata,
354 cipher => $cipher || "Twofish");
355 });
356
357 =item $txn = $fcp->txn_generate_svk_pair
358
359 =item ($public, $private) = @{ $fcp->generate_svk_pair }
360
361 Creates a new SVK pair. Returns an arrayref.
362
363 [
364 "hKs0-WDQA4pVZyMPKNFsK1zapWY",
365 "ZnmvMITaTXBMFGl4~jrjuyWxOWg"
366 ]
367
368 =cut
369
370 $txn->(generate_svk_pair => sub {
371 my ($self) = @_;
372
373 $self->txn ("generate_svk_pair");
374 });
375
376 =item $txn = $fcp->txn_insert_private_key ($private)
377
378 =item $public = $fcp->insert_private_key ($private)
379
380 Inserts a private key. $private can be either an insert URI (must start
381 with C<freenet:SSK@>) or a raw private key (i.e. the private value you get
382 back from C<generate_svk_pair>).
383
384 Returns the public key.
385
386 UNTESTED.
387
388 =cut
389
390 $txn->(insert_private_key => sub {
391 my ($self, $privkey) = @_;
392
393 $self->txn (invert_private_key => private => $privkey);
394 });
395
396 =item $txn = $fcp->txn_get_size ($uri)
397
398 =item $length = $fcp->get_size ($uri)
399
400 Finds and returns the size (rounded up to the nearest power of two) of the
401 given document.
402
403 UNTESTED.
404
405 =cut
406
407 $txn->(get_size => sub {
408 my ($self, $uri) = @_;
409
410 $self->txn (get_size => URI => $uri);
411 });
412
413 =item $txn = $fcp->txn_client_get ($uri [, $htl = 15 [, $removelocal = 0]])
414
415 =item ($metadata, $data) = @{ $fcp->client_get ($uri, $htl, $removelocal)
416
417 Fetches a (small, as it should fit into memory) file from
418 freenet. C<$meta> is the metadata (as returned by C<parse_metadata> or
419 C<undef>).
420
421 The C<$uri> should begin with C<freenet:>, but the scheme is currently
422 added, if missing.
423
424 Due to the overhead, a better method to download big files should be used.
425
426 my ($meta, $data) = @{
427 $fcp->client_get (
428 "freenet:CHK@hdXaxkwZ9rA8-SidT0AN-bniQlgPAwI,XdCDmBuGsd-ulqbLnZ8v~w"
429 )
430 };
431
432 =cut
433
434 $txn->(client_get => sub {
435 my ($self, $uri, $htl, $removelocal) = @_;
436
437 $uri =~ s/^freenet://;
438 $uri = "freenet:$uri";
439
440 $self->txn (client_get => URI => $uri, hops_to_live => xeh (defined $htl ? $htl : 15),
441 remove_local_key => $removelocal ? "true" : "false");
442 });
443
444 =item $txn = $fcp->txn_client_put ($uri, $metadata, $data, $htl, $removelocal)
445
446 =item my $uri = $fcp->client_put ($uri, $metadata, $data, $htl, $removelocal);
447
448 Insert a new key. If the client is inserting a CHK, the URI may be
449 abbreviated as just CHK@. In this case, the node will calculate the
450 CHK.
451
452 C<$meta> can be a reference or a string (ONLY THE STRING CASE IS IMPLEMENTED!).
453
454 THIS INTERFACE IS UNTESTED AND SUBJECT TO CHANGE.
455
456 =cut
457
458 $txn->(client_put => sub {
459 my ($self, $uri, $meta, $data, $htl, $removelocal) = @_;
460
461 $self->txn (client_put => URI => $uri, xeh (defined $htl ? $htl : 15),
462 remove_local_key => $removelocal ? "true" : "false",
463 data => "$meta$data", metadata_length => xeh length $meta);
464 });
465
466 } # transactions
467
468 =item MISSING: (ClientPut), InsertKey
469
470 =back
471
472 =head2 THE Net::FCP::Txn CLASS
473
474 All requests (or transactions) are executed in a asynchronous way. For
475 each request, a C<Net::FCP::Txn> object is created (worse: a tcp
476 connection is created, too).
477
478 For each request there is actually a different subclass (and it's possible
479 to subclass these, although of course not documented).
480
481 The most interesting method is C<result>.
482
483 =over 4
484
485 =cut
486
487 package Net::FCP::Txn;
488
489 use Fcntl;
490 use Socket;
491
492 =item new arg => val,...
493
494 Creates a new C<Net::FCP::Txn> object. Not normally used.
495
496 =cut
497
498 sub new {
499 my $class = shift;
500 my $self = bless { @_ }, $class;
501
502 $self->{signal} = $EVENT->new_signal;
503
504 $self->{fcp}{txn}{$self} = $self;
505
506 my $attr = "";
507 my $data = delete $self->{attr}{data};
508
509 while (my ($k, $v) = each %{$self->{attr}}) {
510 $attr .= (Net::FCP::touc $k) . "=$v\012"
511 }
512
513 if (defined $data) {
514 $attr .= sprintf "DataLength=%x\012", length $data;
515 $data = "Data\012$data";
516 } else {
517 $data = "EndMessage\012";
518 }
519
520 socket my $fh, PF_INET, SOCK_STREAM, 0
521 or Carp::croak "unable to create new tcp socket: $!";
522 binmode $fh, ":raw";
523 fcntl $fh, F_SETFL, O_NONBLOCK;
524 connect $fh, (sockaddr_in $self->{fcp}{port}, inet_aton $self->{fcp}{host})
525 and !$!{EWOULDBLOCK}
526 and !$!{EINPROGRESS}
527 and Carp::croak "FCP::txn: unable to connect to $self->{fcp}{host}:$self->{fcp}{port}: $!\n";
528
529 $self->{sbuf} =
530 "\x00\x00\x00\x02"
531 . (Net::FCP::touc $self->{type})
532 . "\012$attr$data";
533
534 #shutdown $fh, 1; # freenet buggy?, well, it's java...
535
536 $self->{fh} = $fh;
537
538 $self->{w} = $EVENT->new_from_fh ($fh)->cb(sub { $self->fh_ready_w })->poll(0, 1, 1);
539
540 $self;
541 }
542
543 =item $txn = $txn->cb ($coderef)
544
545 Sets a callback to be called when the request is finished. The coderef
546 will be called with the txn as it's sole argument, so it has to call
547 C<result> itself.
548
549 Returns the txn object, useful for chaining.
550
551 Example:
552
553 $fcp->txn_client_get ("freenet:CHK....")
554 ->userdata ("ehrm")
555 ->cb(sub {
556 my $data = shift->result;
557 });
558
559 =cut
560
561 sub cb($$) {
562 my ($self, $cb) = @_;
563 $self->{cb} = $cb;
564 $self;
565 }
566
567 =item $txn = $txn->userdata ([$userdata])
568
569 Set user-specific data. This is useful in progress callbacks. The data can be accessed
570 using C<< $txn->{userdata} >>.
571
572 Returns the txn object, useful for chaining.
573
574 =cut
575
576 sub userdata($$) {
577 my ($self, $data) = @_;
578 $self->{userdata} = $data;
579 $self;
580 }
581
582 =item $txn->cancel (%attr)
583
584 Cancels the operation with a C<cancel> exception anf the given attributes
585 (consider at least giving the attribute C<reason>).
586
587 UNTESTED.
588
589 =cut
590
591 sub cancel {
592 my ($self, %attr) = @_;
593 $self->throw (Net::FCP::Exception->new (cancel => { %attr }));
594 $self->set_result;
595 $self->eof;
596 }
597
598 sub fh_ready_w {
599 my ($self) = @_;
600
601 my $len = syswrite $self->{fh}, $self->{sbuf};
602
603 if ($len > 0) {
604 substr $self->{sbuf}, 0, $len, "";
605 unless (length $self->{sbuf}) {
606 fcntl $self->{fh}, F_SETFL, 0;
607 $self->{w}->cb(sub { $self->fh_ready_r })->poll (1, 0, 1);
608 }
609 } elsif (defined $len) {
610 $self->throw (Net::FCP::Exception->new (network_error => { reason => "unexpected end of file while writing" }));
611 } else {
612 $self->throw (Net::FCP::Exception->new (network_error => { reason => "$!" }));
613 }
614 }
615
616 sub fh_ready_r {
617 my ($self) = @_;
618
619 if (sysread $self->{fh}, $self->{buf}, 65536, length $self->{buf}) {
620 for (;;) {
621 if ($self->{datalen}) {
622 #warn "expecting new datachunk $self->{datalen}, got ".(length $self->{buf})."\n";#d#
623 if (length $self->{buf} >= $self->{datalen}) {
624 $self->rcv_data (substr $self->{buf}, 0, delete $self->{datalen}, "");
625 } else {
626 last;
627 }
628 } elsif ($self->{buf} =~ s/^DataChunk\015?\012Length=([0-9a-fA-F]+)\015?\012Data\015?\012//) {
629 $self->{datalen} = hex $1;
630 #warn "expecting new datachunk $self->{datalen}\n";#d#
631 } elsif ($self->{buf} =~ s/^([a-zA-Z]+)\015?\012(?:(.+?)\015?\012)?EndMessage\015?\012//s) {
632 print "RECV<$1>\n";
633 $self->rcv ($1, {
634 map { my ($a, $b) = split /=/, $_, 2; ((Net::FCP::tolc $a), $b) }
635 split /\015?\012/, $2
636 });
637 } else {
638 last;
639 }
640 }
641 } else {
642 $self->eof;
643 }
644 }
645
646 sub rcv {
647 my ($self, $type, $attr) = @_;
648
649 $type = Net::FCP::tolc $type;
650
651 #use PApp::Util; warn PApp::Util::dumpval [$type, $attr];
652
653 if (my $method = $self->can("rcv_$type")) {
654 $method->($self, $attr, $type);
655 } else {
656 warn "received unexpected reply type '$type' for '$self->{type}', ignoring\n";
657 }
658 }
659
660 # used as a default exception thrower
661 sub rcv_throw_exception {
662 my ($self, $attr, $type) = @_;
663 $self->throw (Net::FCP::Exception->new ($type, $attr));
664 }
665
666 *rcv_failed = \&Net::FCP::Txn::rcv_throw_exception;
667 *rcv_format_error = \&Net::FCP::Txn::rcv_throw_exception;
668
669 sub throw {
670 my ($self, $exc) = @_;
671
672 $self->{exception} = $exc;
673 $self->set_result;
674 $self->eof; # must be last to avoid loops
675 }
676
677 sub set_result {
678 my ($self, $result) = @_;
679
680 unless (exists $self->{result}) {
681 $self->{result} = $result;
682 $self->{cb}->($self) if exists $self->{cb};
683 $self->{signal}->send;
684 }
685 }
686
687 sub eof {
688 my ($self) = @_;
689
690 delete $self->{w};
691 delete $self->{fh};
692
693 delete $self->{fcp}{txn}{$self};
694
695 unless (exists $self->{result}) {
696 $self->throw (Net::FCP::Exception->new (short_data => {
697 reason => "unexpected eof or internal node error",
698 }));
699 }
700 }
701
702 sub progress {
703 my ($self, $type, $attr) = @_;
704
705 $self->{fcp}->progress ($self, $type, $attr);
706 }
707
708 =item $result = $txn->result
709
710 Waits until a result is available and then returns it.
711
712 This waiting is (depending on your event model) not very efficient, as it
713 is done outside the "mainloop". The biggest problem, however, is that it's
714 blocking one thread of execution. Try to use the callback mechanism, if
715 possible, and call result from within the callback (or after is has been
716 run), as then no waiting is necessary.
717
718 =cut
719
720 sub result {
721 my ($self) = @_;
722
723 $self->{signal}->wait while !exists $self->{result};
724
725 die $self->{exception} if $self->{exception};
726
727 return $self->{result};
728 }
729
730 package Net::FCP::Txn::ClientHello;
731
732 use base Net::FCP::Txn;
733
734 sub rcv_node_hello {
735 my ($self, $attr) = @_;
736
737 $self->set_result ($attr);
738 }
739
740 package Net::FCP::Txn::ClientInfo;
741
742 use base Net::FCP::Txn;
743
744 sub rcv_node_info {
745 my ($self, $attr) = @_;
746
747 $self->set_result ($attr);
748 }
749
750 package Net::FCP::Txn::GenerateCHK;
751
752 use base Net::FCP::Txn;
753
754 sub rcv_success {
755 my ($self, $attr) = @_;
756
757 $self->set_result ($attr->{uri});
758 }
759
760 package Net::FCP::Txn::GenerateSVKPair;
761
762 use base Net::FCP::Txn;
763
764 sub rcv_success {
765 my ($self, $attr) = @_;
766 $self->set_result ([$attr->{PublicKey}, $attr->{PrivateKey}]);
767 }
768
769 package Net::FCP::Txn::InsertPrivateKey;
770
771 use base Net::FCP::Txn;
772
773 sub rcv_success {
774 my ($self, $attr) = @_;
775 $self->set_result ($attr->{PublicKey});
776 }
777
778 package Net::FCP::Txn::GetSize;
779
780 use base Net::FCP::Txn;
781
782 sub rcv_success {
783 my ($self, $attr) = @_;
784 $self->set_result (hex $attr->{Length});
785 }
786
787 package Net::FCP::Txn::GetPut;
788
789 # base class for get and put
790
791 use base Net::FCP::Txn;
792
793 *rcv_uri_error = \&Net::FCP::Txn::rcv_throw_exception;
794 *rcv_route_not_found = \&Net::FCP::Txn::rcv_throw_exception;
795
796 sub rcv_restarted {
797 my ($self, $attr, $type) = @_;
798
799 delete $self->{datalength};
800 delete $self->{metalength};
801 delete $self->{data};
802
803 $self->progress ($type, $attr);
804 }
805
806 package Net::FCP::Txn::ClientGet;
807
808 use base Net::FCP::Txn::GetPut;
809
810 *rcv_data_not_found = \&Net::FCP::Txn::rcv_throw_exception;
811
812 sub rcv_data {
813 my ($self, $chunk) = @_;
814
815 $self->{data} .= $chunk;
816
817 $self->progress ("data", { chunk => length $chunk, received => length $self->{data}, total => $self->{datalength} });
818
819 if ($self->{datalength} == length $self->{data}) {
820 my $data = delete $self->{data};
821 my $meta = Net::FCP::parse_metadata substr $data, 0, $self->{metalength}, "";
822
823 $self->set_result ([$meta, $data]);
824 $self->eof;
825 }
826 }
827
828 sub rcv_data_found {
829 my ($self, $attr, $type) = @_;
830
831 $self->progress ($type, $attr);
832
833 $self->{datalength} = hex $attr->{data_length};
834 $self->{metalength} = hex $attr->{metadata_length};
835 }
836
837 package Net::FCP::Txn::ClientPut;
838
839 use base Net::FCP::Txn::GetPut;
840
841 *rcv_size_error = \&Net::FCP::Txn::rcv_throw_exception;
842 *rcv_key_collision = \&Net::FCP::Txn::rcv_throw_exception;
843
844 sub rcv_pending {
845 my ($self, $attr, $type) = @_;
846 $self->progress ($type, $attr);
847 }
848
849 sub rcv_success {
850 my ($self, $attr, $type) = @_;
851 $self->set_result ($attr);
852 }
853
854 =back
855
856 =head2 The Net::FCP::Exception CLASS
857
858 Any unexpected (non-standard) responses that make it impossible to return
859 the advertised result will result in an exception being thrown when the
860 C<result> method is called.
861
862 These exceptions are represented by objects of this class.
863
864 =over 4
865
866 =cut
867
868 package Net::FCP::Exception;
869
870 use overload
871 '""' => sub {
872 "Net::FCP::Exception<<$_[0][0]," . (join ":", %{$_[0][1]}) . ">>";
873 };
874
875 =item $exc = new Net::FCP::Exception $type, \%attr
876
877 Create a new exception object of the given type (a string like
878 C<route_not_found>), and a hashref containing additional attributes
879 (usually the attributes of the message causing the exception).
880
881 =cut
882
883 sub new {
884 my ($class, $type, $attr) = @_;
885
886 bless [Net::FCP::tolc $type, { %$attr }], $class;
887 }
888
889 =item $exc->type([$type])
890
891 With no arguments, returns the exception type. Otherwise a boolean
892 indicating wether the exception is of the given type is returned.
893
894 =cut
895
896 sub type {
897 my ($self, $type) = @_;
898
899 @_ >= 2
900 ? $self->[0] eq $type
901 : $self->[0];
902 }
903
904 =item $exc->attr([$attr])
905
906 With no arguments, returns the attributes. Otherwise the named attribute
907 value is returned.
908
909 =cut
910
911 sub attr {
912 my ($self, $attr) = @_;
913
914 @_ >= 2
915 ? $self->[1]{$attr}
916 : $self->[1];
917 }
918
919 =back
920
921 =head1 SEE ALSO
922
923 L<http://freenet.sf.net>.
924
925 =head1 BUGS
926
927 =head1 AUTHOR
928
929 Marc Lehmann <pcg@goof.com>
930 http://www.goof.com/pcg/marc/
931
932 =cut
933
934 package Net::FCP::Event::Auto;
935
936 my @models = (
937 [Coro => Coro::Event::],
938 [Event => Event::],
939 [Glib => Glib::],
940 [Tk => Tk::],
941 );
942
943 sub AUTOLOAD {
944 $AUTOLOAD =~ s/.*://;
945
946 for (@models) {
947 my ($model, $package) = @$_;
948 if (defined ${"$package\::VERSION"}) {
949 $EVENT = "Net::FCP::Event::$model";
950 eval "require $EVENT"; die if $@;
951 goto &{"$EVENT\::$AUTOLOAD"};
952 }
953 }
954
955 for (@models) {
956 my ($model, $package) = @$_;
957 $EVENT = "Net::FCP::Event::$model";
958 if (eval "require $EVENT") {
959 goto &{"$EVENT\::$AUTOLOAD"};
960 }
961 }
962
963 die "No event module selected for Net::FCP and autodetect failed. Install any of these: Coro, Event, Glib or Tk.";
964 }
965
966 1;
967