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

File Contents

# User Rev Content
1 root 1.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 root 1.9 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 root 1.1
40 root 1.20 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 root 1.17 =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 root 1.1 =head2 THE Net::FCP CLASS
68    
69     =over 4
70    
71     =cut
72    
73     package Net::FCP;
74    
75     use Carp;
76    
77 root 1.24 $VERSION = 0.6;
78 root 1.10
79     no warnings;
80 root 1.1
81 root 1.9 our $EVENT = Net::FCP::Event::Auto::;
82 root 1.1
83 root 1.9 sub import {
84     shift;
85 root 1.1
86 root 1.9 for (@_) {
87     if (/^event=(\w+)$/) {
88     $EVENT = "Net::FCP::Event::$1";
89 root 1.20 eval "require $EVENT";
90 root 1.9 }
91     }
92 root 1.12 die $@ if $@;
93 root 1.1 }
94    
95 root 1.2 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 root 1.27 1 while s/(SVK|CHK|URI)([^_])/$1\_$2/i;
105     1 while s/([^_])(SVK|CHK|URI)/$1\_$2/i;
106 root 1.2 s/(?<=[a-z])(?=[A-Z])/_/g;
107     lc $_;
108     }
109    
110 root 1.23 # the opposite of hex
111     sub xeh($) {
112     sprintf "%x", $_[0];
113     }
114    
115 root 1.7 =item $meta = Net::FCP::parse_metadata $string
116    
117     Parse a metadata string and return it.
118    
119 root 1.21 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 root 1.7
123     All other headers are represented by arrayrefs (they can be repeated).
124    
125 root 1.21 Since this description is confusing, here is a rather verbose example of a
126     parsed manifest:
127 root 1.7
128     (
129 root 1.21 raw => "Version...",
130 root 1.7 version => { revision => 1 },
131     document => [
132     {
133 root 1.17 info => { format" => "image/jpeg" },
134 root 1.7 name => "background.jpg",
135 root 1.17 redirect => { target => "freenet:CHK\@ZcagI,ra726bSw" },
136 root 1.7 },
137     {
138 root 1.17 info => { format" => "text/html" },
139 root 1.7 name => ".next",
140 root 1.17 redirect => { target => "freenet:SSK\@ilUPAgM/TFEE/3" },
141 root 1.7 },
142     {
143 root 1.17 info => { format" => "text/html" },
144     redirect => { target => "freenet:CHK\@8M8Po8ucwI,8xA" },
145 root 1.7 }
146     ]
147     )
148    
149     =cut
150    
151     sub parse_metadata {
152 root 1.21 my $data = shift;
153     my $meta = { raw => $data };
154 root 1.7
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 root 1.12 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 root 1.15 $hdr->{$p[0]}{$p[1]}{$p[2]} = $v if @p == 3;
166 root 1.12 die "FATAL: 4+ dot metadata" if @p >= 4;
167 root 1.7 }
168    
169     if ($data =~ /\GEndPart\015?\012/gc) {
170 root 1.12 # nop
171 root 1.17 } elsif ($data =~ /\GEnd(\015?\012|$)/gc) {
172 root 1.7 last;
173     } elsif ($data =~ /\G([A-Za-z0-9.\-]+)\015?\012/gcs) {
174     push @{$meta->{tolc $1}}, $hdr = {};
175     } elsif ($data =~ /\G(.*)/gcs) {
176 root 1.18 print STDERR "metadata format error ($1), please report this string: <<$data>>";
177     die "metadata format error";
178 root 1.7 }
179     }
180     }
181    
182     #$meta->{tail} = substr $data, pos $data;
183    
184     $meta;
185     }
186    
187 root 1.27 =item $fcp = new Net::FCP [host => $host][, port => $port][, progress => \&cb]
188 root 1.1
189     Create a new virtual FCP connection to the given host and port (default
190 root 1.5 127.0.0.1:8481, or the environment variables C<FREDHOST> and C<FREDPORT>).
191 root 1.1
192     Connections are virtual because no persistent physical connection is
193 root 1.17 established.
194    
195 root 1.27 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 root 1.17 =begin comment
206    
207     However, the existance of the node is checked by executing a
208 root 1.1 C<ClientHello> transaction.
209    
210 root 1.17 =end
211    
212 root 1.1 =cut
213    
214     sub new {
215     my $class = shift;
216     my $self = bless { @_ }, $class;
217    
218 root 1.5 $self->{host} ||= $ENV{FREDHOST} || "127.0.0.1";
219 root 1.12 $self->{port} ||= $ENV{FREDPORT} || 8481;
220 root 1.1
221 root 1.12 #$self->{nodehello} = $self->client_hello
222     # or croak "unable to get nodehello from node\n";
223 root 1.1
224     $self;
225     }
226    
227 root 1.9 sub progress {
228     my ($self, $txn, $type, $attr) = @_;
229 root 1.27
230     $self->{progress}->($self, $txn, $type, $attr)
231     if $self->{progress};
232 root 1.18 #warn "progress<$txn,$type," . (join ":", %$attr) . ">\n";
233 root 1.9 }
234    
235 root 1.1 =item $txn = $fcp->txn(type => attr => val,...)
236    
237     The low-level interface to transactions. Don't use it.
238    
239 root 1.12 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 root 1.1 =cut
262    
263     sub txn {
264     my ($self, $type, %attr) = @_;
265    
266 root 1.2 $type = touc $type;
267    
268     my $txn = "Net::FCP::Txn::$type"->new(fcp => $self, type => tolc $type, attr => \%attr);
269 root 1.1
270     $txn;
271     }
272    
273 root 1.17 { # transactions
274    
275     my $txn = sub {
276 root 1.1 my ($name, $sub) = @_;
277 root 1.17 *{"txn_$name"} = $sub;
278 root 1.1 *{$name} = sub { $sub->(@_)->result };
279 root 1.17 };
280 root 1.1
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 root 1.2 max_file_size => "5f5e100",
289 root 1.4 node => "Fred,0.6,1.46,7050"
290 root 1.2 protocol => "1.2",
291 root 1.1 }
292    
293     =cut
294    
295 root 1.17 $txn->(client_hello => sub {
296 root 1.1 my ($self) = @_;
297    
298 root 1.2 $self->txn ("client_hello");
299 root 1.17 });
300 root 1.1
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 root 1.2 active_jobs => "1f",
309     allocated_memory => "bde0000",
310     architecture => "i386",
311     available_threads => 17,
312 root 1.4 datastore_free => "5ce03400",
313     datastore_max => "2540be400",
314 root 1.2 datastore_used => "1f72bb000",
315 root 1.4 estimated_load => 52,
316     free_memory => "5cc0148",
317 root 1.2 is_transient => "false",
318 root 1.4 java_name => "Java HotSpot(_T_M) Server VM",
319 root 1.2 java_vendor => "http://www.blackdown.org/",
320 root 1.4 java_version => "Blackdown-1.4.1-01",
321     least_recent_timestamp => "f41538b878",
322     max_file_size => "5f5e100",
323 root 1.2 most_recent_timestamp => "f77e2cc520"
324 root 1.4 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 root 1.1 }
330    
331     =cut
332    
333 root 1.17 $txn->(client_info => sub {
334 root 1.1 my ($self) = @_;
335    
336 root 1.2 $self->txn ("client_info");
337 root 1.17 });
338 root 1.1
339 root 1.21 =item $txn = $fcp->txn_generate_chk ($metadata, $data[, $cipher])
340 root 1.1
341 root 1.21 =item $uri = $fcp->generate_chk ($metadata, $data[, $cipher])
342 root 1.1
343 root 1.27 Calculates a CHK, given the metadata and data. C<$cipher> is either
344 root 1.21 C<Rijndael> or C<Twofish>, with the latter being the default.
345 root 1.1
346     =cut
347    
348 root 1.17 $txn->(generate_chk => sub {
349 root 1.21 my ($self, $metadata, $data, $cipher) = @_;
350 root 1.1
351 root 1.21 $self->txn (generate_chk =>
352     data => "$metadata$data",
353 root 1.23 metadata_length => xeh length $metadata,
354 root 1.21 cipher => $cipher || "Twofish");
355 root 1.17 });
356 root 1.1
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 root 1.17 $txn->(generate_svk_pair => sub {
371 root 1.1 my ($self) = @_;
372    
373 root 1.2 $self->txn ("generate_svk_pair");
374 root 1.17 });
375 root 1.1
376     =item $txn = $fcp->txn_insert_private_key ($private)
377    
378 root 1.17 =item $public = $fcp->insert_private_key ($private)
379 root 1.1
380     Inserts a private key. $private can be either an insert URI (must start
381 root 1.17 with C<freenet:SSK@>) or a raw private key (i.e. the private value you get
382     back from C<generate_svk_pair>).
383 root 1.1
384     Returns the public key.
385    
386     UNTESTED.
387    
388     =cut
389    
390 root 1.17 $txn->(insert_private_key => sub {
391 root 1.1 my ($self, $privkey) = @_;
392    
393 root 1.2 $self->txn (invert_private_key => private => $privkey);
394 root 1.17 });
395 root 1.1
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 root 1.17 $txn->(get_size => sub {
408 root 1.1 my ($self, $uri) = @_;
409    
410 root 1.2 $self->txn (get_size => URI => $uri);
411 root 1.17 });
412 root 1.1
413 root 1.5 =item $txn = $fcp->txn_client_get ($uri [, $htl = 15 [, $removelocal = 0]])
414    
415 root 1.7 =item ($metadata, $data) = @{ $fcp->client_get ($uri, $htl, $removelocal)
416 root 1.5
417 root 1.7 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 root 1.5
421 root 1.27 The C<$uri> should begin with C<freenet:>, but the scheme is currently
422     added, if missing.
423    
424 root 1.7 Due to the overhead, a better method to download big files should be used.
425 root 1.5
426 root 1.7 my ($meta, $data) = @{
427 root 1.5 $fcp->client_get (
428     "freenet:CHK@hdXaxkwZ9rA8-SidT0AN-bniQlgPAwI,XdCDmBuGsd-ulqbLnZ8v~w"
429     )
430     };
431    
432     =cut
433    
434 root 1.17 $txn->(client_get => sub {
435 root 1.5 my ($self, $uri, $htl, $removelocal) = @_;
436    
437 root 1.26 $uri =~ s/^freenet://;
438     $uri = "freenet:$uri";
439    
440 root 1.23 $self->txn (client_get => URI => $uri, hops_to_live => xeh (defined $htl ? $htl : 15),
441 root 1.17 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 root 1.23 $self->txn (client_put => URI => $uri, xeh (defined $htl ? $htl : 15),
462 root 1.17 remove_local_key => $removelocal ? "true" : "false",
463 root 1.23 data => "$meta$data", metadata_length => xeh length $meta);
464 root 1.17 });
465    
466     } # transactions
467 root 1.5
468 root 1.23 =item MISSING: (ClientPut), InsertKey
469 root 1.1
470     =back
471    
472     =head2 THE Net::FCP::Txn CLASS
473    
474 root 1.23 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 root 1.1
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 root 1.12 use Fcntl;
490     use Socket;
491    
492 root 1.1 =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 root 1.12 $self->{signal} = $EVENT->new_signal;
503    
504     $self->{fcp}{txn}{$self} = $self;
505    
506 root 1.1 my $attr = "";
507     my $data = delete $self->{attr}{data};
508    
509     while (my ($k, $v) = each %{$self->{attr}}) {
510 root 1.2 $attr .= (Net::FCP::touc $k) . "=$v\012"
511 root 1.1 }
512    
513     if (defined $data) {
514 root 1.21 $attr .= sprintf "DataLength=%x\012", length $data;
515 root 1.1 $data = "Data\012$data";
516     } else {
517     $data = "EndMessage\012";
518     }
519    
520 root 1.12 socket my $fh, PF_INET, SOCK_STREAM, 0
521     or Carp::croak "unable to create new tcp socket: $!";
522 root 1.1 binmode $fh, ":raw";
523 root 1.12 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 root 1.21 . (Net::FCP::touc $self->{type})
532 root 1.12 . "\012$attr$data";
533 root 1.1
534 root 1.21 #shutdown $fh, 1; # freenet buggy?, well, it's java...
535 root 1.1
536     $self->{fh} = $fh;
537    
538 root 1.12 $self->{w} = $EVENT->new_from_fh ($fh)->cb(sub { $self->fh_ready_w })->poll(0, 1, 1);
539 root 1.1
540     $self;
541     }
542    
543 root 1.12 =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 root 1.9
551 root 1.12 Example:
552    
553     $fcp->txn_client_get ("freenet:CHK....")
554     ->userdata ("ehrm")
555     ->cb(sub {
556     my $data = shift->result;
557     });
558 root 1.9
559     =cut
560    
561 root 1.12 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 root 1.9 my ($self, $data) = @_;
578 root 1.12 $self->{userdata} = $data;
579     $self;
580     }
581    
582 root 1.17 =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 root 1.12 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 root 1.9 }
615    
616 root 1.12 sub fh_ready_r {
617 root 1.1 my ($self) = @_;
618    
619     if (sysread $self->{fh}, $self->{buf}, 65536, length $self->{buf}) {
620     for (;;) {
621     if ($self->{datalen}) {
622 root 1.13 #warn "expecting new datachunk $self->{datalen}, got ".(length $self->{buf})."\n";#d#
623 root 1.1 if (length $self->{buf} >= $self->{datalen}) {
624 root 1.11 $self->rcv_data (substr $self->{buf}, 0, delete $self->{datalen}, "");
625 root 1.1 } else {
626     last;
627     }
628 root 1.5 } elsif ($self->{buf} =~ s/^DataChunk\015?\012Length=([0-9a-fA-F]+)\015?\012Data\015?\012//) {
629     $self->{datalen} = hex $1;
630 root 1.13 #warn "expecting new datachunk $self->{datalen}\n";#d#
631 root 1.7 } elsif ($self->{buf} =~ s/^([a-zA-Z]+)\015?\012(?:(.+?)\015?\012)?EndMessage\015?\012//s) {
632 root 1.27 print "RECV<$1>\n";
633 root 1.2 $self->rcv ($1, {
634     map { my ($a, $b) = split /=/, $_, 2; ((Net::FCP::tolc $a), $b) }
635     split /\015?\012/, $2
636     });
637 root 1.1 } else {
638     last;
639     }
640     }
641     } else {
642     $self->eof;
643     }
644     }
645    
646     sub rcv {
647     my ($self, $type, $attr) = @_;
648    
649 root 1.2 $type = Net::FCP::tolc $type;
650    
651 root 1.5 #use PApp::Util; warn PApp::Util::dumpval [$type, $attr];
652    
653 root 1.2 if (my $method = $self->can("rcv_$type")) {
654 root 1.1 $method->($self, $attr, $type);
655     } else {
656     warn "received unexpected reply type '$type' for '$self->{type}', ignoring\n";
657     }
658     }
659    
660 root 1.12 # used as a default exception thrower
661     sub rcv_throw_exception {
662     my ($self, $attr, $type) = @_;
663 root 1.15 $self->throw (Net::FCP::Exception->new ($type, $attr));
664 root 1.12 }
665    
666     *rcv_failed = \&Net::FCP::Txn::rcv_throw_exception;
667     *rcv_format_error = \&Net::FCP::Txn::rcv_throw_exception;
668    
669 root 1.9 sub throw {
670     my ($self, $exc) = @_;
671    
672     $self->{exception} = $exc;
673 root 1.17 $self->set_result;
674 root 1.12 $self->eof; # must be last to avoid loops
675 root 1.9 }
676    
677 root 1.5 sub set_result {
678 root 1.1 my ($self, $result) = @_;
679    
680 root 1.12 unless (exists $self->{result}) {
681     $self->{result} = $result;
682     $self->{cb}->($self) if exists $self->{cb};
683     $self->{signal}->send;
684     }
685 root 1.1 }
686    
687 root 1.5 sub eof {
688     my ($self) = @_;
689 root 1.12
690     delete $self->{w};
691     delete $self->{fh};
692    
693     delete $self->{fcp}{txn}{$self};
694    
695 root 1.17 unless (exists $self->{result}) {
696     $self->throw (Net::FCP::Exception->new (short_data => {
697     reason => "unexpected eof or internal node error",
698     }));
699     }
700 root 1.5 }
701    
702 root 1.9 sub progress {
703     my ($self, $type, $attr) = @_;
704 root 1.27
705 root 1.9 $self->{fcp}->progress ($self, $type, $attr);
706     }
707    
708 root 1.1 =item $result = $txn->result
709    
710     Waits until a result is available and then returns it.
711    
712 root 1.5 This waiting is (depending on your event model) not very efficient, as it
713 root 1.23 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 root 1.1
718     =cut
719    
720     sub result {
721     my ($self) = @_;
722    
723 root 1.12 $self->{signal}->wait while !exists $self->{result};
724 root 1.9
725     die $self->{exception} if $self->{exception};
726 root 1.1
727     return $self->{result};
728     }
729    
730     package Net::FCP::Txn::ClientHello;
731    
732     use base Net::FCP::Txn;
733    
734 root 1.2 sub rcv_node_hello {
735 root 1.1 my ($self, $attr) = @_;
736    
737 root 1.5 $self->set_result ($attr);
738 root 1.1 }
739    
740     package Net::FCP::Txn::ClientInfo;
741    
742     use base Net::FCP::Txn;
743    
744 root 1.2 sub rcv_node_info {
745 root 1.1 my ($self, $attr) = @_;
746    
747 root 1.5 $self->set_result ($attr);
748 root 1.1 }
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 root 1.21 $self->set_result ($attr->{uri});
758 root 1.1 }
759    
760     package Net::FCP::Txn::GenerateSVKPair;
761    
762     use base Net::FCP::Txn;
763    
764     sub rcv_success {
765     my ($self, $attr) = @_;
766 root 1.5 $self->set_result ([$attr->{PublicKey}, $attr->{PrivateKey}]);
767 root 1.1 }
768    
769 root 1.17 package Net::FCP::Txn::InsertPrivateKey;
770 root 1.1
771     use base Net::FCP::Txn;
772    
773     sub rcv_success {
774     my ($self, $attr) = @_;
775 root 1.5 $self->set_result ($attr->{PublicKey});
776 root 1.1 }
777    
778     package Net::FCP::Txn::GetSize;
779    
780     use base Net::FCP::Txn;
781    
782     sub rcv_success {
783     my ($self, $attr) = @_;
784 root 1.23 $self->set_result (hex $attr->{Length});
785 root 1.5 }
786    
787 root 1.12 package Net::FCP::Txn::GetPut;
788    
789     # base class for get and put
790    
791     use base Net::FCP::Txn;
792    
793 root 1.27 *rcv_uri_error = \&Net::FCP::Txn::rcv_throw_exception;
794     *rcv_route_not_found = \&Net::FCP::Txn::rcv_throw_exception;
795 root 1.12
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 root 1.5 package Net::FCP::Txn::ClientGet;
807    
808 root 1.12 use base Net::FCP::Txn::GetPut;
809    
810     *rcv_data_not_found = \&Net::FCP::Txn::rcv_throw_exception;
811 root 1.5
812 root 1.17 sub rcv_data {
813     my ($self, $chunk) = @_;
814 root 1.9
815 root 1.17 $self->{data} .= $chunk;
816 root 1.5
817 root 1.19 $self->progress ("data", { chunk => length $chunk, received => length $self->{data}, total => $self->{datalength} });
818 root 1.9
819 root 1.12 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 root 1.22 $self->eof;
825 root 1.12 }
826 root 1.9 }
827    
828 root 1.17 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 root 1.12 package Net::FCP::Txn::ClientPut;
838 root 1.9
839 root 1.12 use base Net::FCP::Txn::GetPut;
840 root 1.9
841 root 1.12 *rcv_size_error = \&Net::FCP::Txn::rcv_throw_exception;
842     *rcv_key_collision = \&Net::FCP::Txn::rcv_throw_exception;
843 root 1.9
844 root 1.12 sub rcv_pending {
845 root 1.9 my ($self, $attr, $type) = @_;
846     $self->progress ($type, $attr);
847 root 1.5 }
848    
849 root 1.12 sub rcv_success {
850     my ($self, $attr, $type) = @_;
851     $self->set_result ($attr);
852 root 1.9 }
853    
854 root 1.17 =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 root 1.9 package Net::FCP::Exception;
869    
870     use overload
871     '""' => sub {
872 root 1.22 "Net::FCP::Exception<<$_[0][0]," . (join ":", %{$_[0][1]}) . ">>";
873 root 1.9 };
874    
875 root 1.17 =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 root 1.9 sub new {
884     my ($class, $type, $attr) = @_;
885    
886 root 1.12 bless [Net::FCP::tolc $type, { %$attr }], $class;
887 root 1.17 }
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 root 1.1 }
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 root 1.20
934     package Net::FCP::Event::Auto;
935    
936     my @models = (
937 root 1.27 [Coro => Coro::Event::],
938 root 1.20 [Event => Event::],
939 root 1.27 [Glib => Glib::],
940 root 1.20 [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 root 1.1
966     1;
967