ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Net-FCP/FCP.pm
Revision: 1.28
Committed: Thu May 13 16:13:42 2004 UTC (22 years, 4 months ago) by root
Branch: MAIN
Changes since 1.27: +0 -2 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.9 }
233    
234 root 1.1 =item $txn = $fcp->txn(type => attr => val,...)
235    
236     The low-level interface to transactions. Don't use it.
237    
238 root 1.12 Here are some examples of using transactions:
239    
240     The blocking case, no (visible) transactions involved:
241    
242     my $nodehello = $fcp->client_hello;
243    
244     A transaction used in a blocking fashion:
245    
246     my $txn = $fcp->txn_client_hello;
247     ...
248     my $nodehello = $txn->result;
249    
250     Or shorter:
251    
252     my $nodehello = $fcp->txn_client_hello->result;
253    
254     Setting callbacks:
255    
256     $fcp->txn_client_hello->cb(
257     sub { my $nodehello => $_[0]->result }
258     );
259    
260 root 1.1 =cut
261    
262     sub txn {
263     my ($self, $type, %attr) = @_;
264    
265 root 1.2 $type = touc $type;
266    
267     my $txn = "Net::FCP::Txn::$type"->new(fcp => $self, type => tolc $type, attr => \%attr);
268 root 1.1
269     $txn;
270     }
271    
272 root 1.17 { # transactions
273    
274     my $txn = sub {
275 root 1.1 my ($name, $sub) = @_;
276 root 1.17 *{"txn_$name"} = $sub;
277 root 1.1 *{$name} = sub { $sub->(@_)->result };
278 root 1.17 };
279 root 1.1
280     =item $txn = $fcp->txn_client_hello
281    
282     =item $nodehello = $fcp->client_hello
283    
284     Executes a ClientHello request and returns it's results.
285    
286     {
287 root 1.2 max_file_size => "5f5e100",
288 root 1.4 node => "Fred,0.6,1.46,7050"
289 root 1.2 protocol => "1.2",
290 root 1.1 }
291    
292     =cut
293    
294 root 1.17 $txn->(client_hello => sub {
295 root 1.1 my ($self) = @_;
296    
297 root 1.2 $self->txn ("client_hello");
298 root 1.17 });
299 root 1.1
300     =item $txn = $fcp->txn_client_info
301    
302     =item $nodeinfo = $fcp->client_info
303    
304     Executes a ClientInfo request and returns it's results.
305    
306     {
307 root 1.2 active_jobs => "1f",
308     allocated_memory => "bde0000",
309     architecture => "i386",
310     available_threads => 17,
311 root 1.4 datastore_free => "5ce03400",
312     datastore_max => "2540be400",
313 root 1.2 datastore_used => "1f72bb000",
314 root 1.4 estimated_load => 52,
315     free_memory => "5cc0148",
316 root 1.2 is_transient => "false",
317 root 1.4 java_name => "Java HotSpot(_T_M) Server VM",
318 root 1.2 java_vendor => "http://www.blackdown.org/",
319 root 1.4 java_version => "Blackdown-1.4.1-01",
320     least_recent_timestamp => "f41538b878",
321     max_file_size => "5f5e100",
322 root 1.2 most_recent_timestamp => "f77e2cc520"
323 root 1.4 node_address => "1.2.3.4",
324     node_port => 369,
325     operating_system => "Linux",
326     operating_system_version => "2.4.20",
327     routing_time => "a5",
328 root 1.1 }
329    
330     =cut
331    
332 root 1.17 $txn->(client_info => sub {
333 root 1.1 my ($self) = @_;
334    
335 root 1.2 $self->txn ("client_info");
336 root 1.17 });
337 root 1.1
338 root 1.21 =item $txn = $fcp->txn_generate_chk ($metadata, $data[, $cipher])
339 root 1.1
340 root 1.21 =item $uri = $fcp->generate_chk ($metadata, $data[, $cipher])
341 root 1.1
342 root 1.27 Calculates a CHK, given the metadata and data. C<$cipher> is either
343 root 1.21 C<Rijndael> or C<Twofish>, with the latter being the default.
344 root 1.1
345     =cut
346    
347 root 1.17 $txn->(generate_chk => sub {
348 root 1.21 my ($self, $metadata, $data, $cipher) = @_;
349 root 1.1
350 root 1.21 $self->txn (generate_chk =>
351     data => "$metadata$data",
352 root 1.23 metadata_length => xeh length $metadata,
353 root 1.21 cipher => $cipher || "Twofish");
354 root 1.17 });
355 root 1.1
356     =item $txn = $fcp->txn_generate_svk_pair
357    
358     =item ($public, $private) = @{ $fcp->generate_svk_pair }
359    
360     Creates a new SVK pair. Returns an arrayref.
361    
362     [
363     "hKs0-WDQA4pVZyMPKNFsK1zapWY",
364     "ZnmvMITaTXBMFGl4~jrjuyWxOWg"
365     ]
366    
367     =cut
368    
369 root 1.17 $txn->(generate_svk_pair => sub {
370 root 1.1 my ($self) = @_;
371    
372 root 1.2 $self->txn ("generate_svk_pair");
373 root 1.17 });
374 root 1.1
375     =item $txn = $fcp->txn_insert_private_key ($private)
376    
377 root 1.17 =item $public = $fcp->insert_private_key ($private)
378 root 1.1
379     Inserts a private key. $private can be either an insert URI (must start
380 root 1.17 with C<freenet:SSK@>) or a raw private key (i.e. the private value you get
381     back from C<generate_svk_pair>).
382 root 1.1
383     Returns the public key.
384    
385     UNTESTED.
386    
387     =cut
388    
389 root 1.17 $txn->(insert_private_key => sub {
390 root 1.1 my ($self, $privkey) = @_;
391    
392 root 1.2 $self->txn (invert_private_key => private => $privkey);
393 root 1.17 });
394 root 1.1
395     =item $txn = $fcp->txn_get_size ($uri)
396    
397     =item $length = $fcp->get_size ($uri)
398    
399     Finds and returns the size (rounded up to the nearest power of two) of the
400     given document.
401    
402     UNTESTED.
403    
404     =cut
405    
406 root 1.17 $txn->(get_size => sub {
407 root 1.1 my ($self, $uri) = @_;
408    
409 root 1.2 $self->txn (get_size => URI => $uri);
410 root 1.17 });
411 root 1.1
412 root 1.5 =item $txn = $fcp->txn_client_get ($uri [, $htl = 15 [, $removelocal = 0]])
413    
414 root 1.7 =item ($metadata, $data) = @{ $fcp->client_get ($uri, $htl, $removelocal)
415 root 1.5
416 root 1.7 Fetches a (small, as it should fit into memory) file from
417     freenet. C<$meta> is the metadata (as returned by C<parse_metadata> or
418     C<undef>).
419 root 1.5
420 root 1.27 The C<$uri> should begin with C<freenet:>, but the scheme is currently
421     added, if missing.
422    
423 root 1.7 Due to the overhead, a better method to download big files should be used.
424 root 1.5
425 root 1.7 my ($meta, $data) = @{
426 root 1.5 $fcp->client_get (
427     "freenet:CHK@hdXaxkwZ9rA8-SidT0AN-bniQlgPAwI,XdCDmBuGsd-ulqbLnZ8v~w"
428     )
429     };
430    
431     =cut
432    
433 root 1.17 $txn->(client_get => sub {
434 root 1.5 my ($self, $uri, $htl, $removelocal) = @_;
435    
436 root 1.26 $uri =~ s/^freenet://;
437     $uri = "freenet:$uri";
438    
439 root 1.23 $self->txn (client_get => URI => $uri, hops_to_live => xeh (defined $htl ? $htl : 15),
440 root 1.17 remove_local_key => $removelocal ? "true" : "false");
441     });
442    
443     =item $txn = $fcp->txn_client_put ($uri, $metadata, $data, $htl, $removelocal)
444    
445     =item my $uri = $fcp->client_put ($uri, $metadata, $data, $htl, $removelocal);
446    
447     Insert a new key. If the client is inserting a CHK, the URI may be
448     abbreviated as just CHK@. In this case, the node will calculate the
449     CHK.
450    
451     C<$meta> can be a reference or a string (ONLY THE STRING CASE IS IMPLEMENTED!).
452    
453     THIS INTERFACE IS UNTESTED AND SUBJECT TO CHANGE.
454    
455     =cut
456    
457     $txn->(client_put => sub {
458     my ($self, $uri, $meta, $data, $htl, $removelocal) = @_;
459    
460 root 1.23 $self->txn (client_put => URI => $uri, xeh (defined $htl ? $htl : 15),
461 root 1.17 remove_local_key => $removelocal ? "true" : "false",
462 root 1.23 data => "$meta$data", metadata_length => xeh length $meta);
463 root 1.17 });
464    
465     } # transactions
466 root 1.5
467 root 1.23 =item MISSING: (ClientPut), InsertKey
468 root 1.1
469     =back
470    
471     =head2 THE Net::FCP::Txn CLASS
472    
473 root 1.23 All requests (or transactions) are executed in a asynchronous way. For
474     each request, a C<Net::FCP::Txn> object is created (worse: a tcp
475     connection is created, too).
476 root 1.1
477     For each request there is actually a different subclass (and it's possible
478     to subclass these, although of course not documented).
479    
480     The most interesting method is C<result>.
481    
482     =over 4
483    
484     =cut
485    
486     package Net::FCP::Txn;
487    
488 root 1.12 use Fcntl;
489     use Socket;
490    
491 root 1.1 =item new arg => val,...
492    
493     Creates a new C<Net::FCP::Txn> object. Not normally used.
494    
495     =cut
496    
497     sub new {
498     my $class = shift;
499     my $self = bless { @_ }, $class;
500    
501 root 1.12 $self->{signal} = $EVENT->new_signal;
502    
503     $self->{fcp}{txn}{$self} = $self;
504    
505 root 1.1 my $attr = "";
506     my $data = delete $self->{attr}{data};
507    
508     while (my ($k, $v) = each %{$self->{attr}}) {
509 root 1.2 $attr .= (Net::FCP::touc $k) . "=$v\012"
510 root 1.1 }
511    
512     if (defined $data) {
513 root 1.21 $attr .= sprintf "DataLength=%x\012", length $data;
514 root 1.1 $data = "Data\012$data";
515     } else {
516     $data = "EndMessage\012";
517     }
518    
519 root 1.12 socket my $fh, PF_INET, SOCK_STREAM, 0
520     or Carp::croak "unable to create new tcp socket: $!";
521 root 1.1 binmode $fh, ":raw";
522 root 1.12 fcntl $fh, F_SETFL, O_NONBLOCK;
523     connect $fh, (sockaddr_in $self->{fcp}{port}, inet_aton $self->{fcp}{host})
524     and !$!{EWOULDBLOCK}
525     and !$!{EINPROGRESS}
526     and Carp::croak "FCP::txn: unable to connect to $self->{fcp}{host}:$self->{fcp}{port}: $!\n";
527    
528     $self->{sbuf} =
529     "\x00\x00\x00\x02"
530 root 1.21 . (Net::FCP::touc $self->{type})
531 root 1.12 . "\012$attr$data";
532 root 1.1
533 root 1.21 #shutdown $fh, 1; # freenet buggy?, well, it's java...
534 root 1.1
535     $self->{fh} = $fh;
536    
537 root 1.12 $self->{w} = $EVENT->new_from_fh ($fh)->cb(sub { $self->fh_ready_w })->poll(0, 1, 1);
538 root 1.1
539     $self;
540     }
541    
542 root 1.12 =item $txn = $txn->cb ($coderef)
543    
544     Sets a callback to be called when the request is finished. The coderef
545     will be called with the txn as it's sole argument, so it has to call
546     C<result> itself.
547    
548     Returns the txn object, useful for chaining.
549 root 1.9
550 root 1.12 Example:
551    
552     $fcp->txn_client_get ("freenet:CHK....")
553     ->userdata ("ehrm")
554     ->cb(sub {
555     my $data = shift->result;
556     });
557 root 1.9
558     =cut
559    
560 root 1.12 sub cb($$) {
561     my ($self, $cb) = @_;
562     $self->{cb} = $cb;
563     $self;
564     }
565    
566     =item $txn = $txn->userdata ([$userdata])
567    
568     Set user-specific data. This is useful in progress callbacks. The data can be accessed
569     using C<< $txn->{userdata} >>.
570    
571     Returns the txn object, useful for chaining.
572    
573     =cut
574    
575     sub userdata($$) {
576 root 1.9 my ($self, $data) = @_;
577 root 1.12 $self->{userdata} = $data;
578     $self;
579     }
580    
581 root 1.17 =item $txn->cancel (%attr)
582    
583     Cancels the operation with a C<cancel> exception anf the given attributes
584     (consider at least giving the attribute C<reason>).
585    
586     UNTESTED.
587    
588     =cut
589    
590     sub cancel {
591     my ($self, %attr) = @_;
592     $self->throw (Net::FCP::Exception->new (cancel => { %attr }));
593     $self->set_result;
594     $self->eof;
595     }
596    
597 root 1.12 sub fh_ready_w {
598     my ($self) = @_;
599    
600     my $len = syswrite $self->{fh}, $self->{sbuf};
601    
602     if ($len > 0) {
603     substr $self->{sbuf}, 0, $len, "";
604     unless (length $self->{sbuf}) {
605     fcntl $self->{fh}, F_SETFL, 0;
606     $self->{w}->cb(sub { $self->fh_ready_r })->poll (1, 0, 1);
607     }
608     } elsif (defined $len) {
609     $self->throw (Net::FCP::Exception->new (network_error => { reason => "unexpected end of file while writing" }));
610     } else {
611     $self->throw (Net::FCP::Exception->new (network_error => { reason => "$!" }));
612     }
613 root 1.9 }
614    
615 root 1.12 sub fh_ready_r {
616 root 1.1 my ($self) = @_;
617    
618     if (sysread $self->{fh}, $self->{buf}, 65536, length $self->{buf}) {
619     for (;;) {
620     if ($self->{datalen}) {
621 root 1.13 #warn "expecting new datachunk $self->{datalen}, got ".(length $self->{buf})."\n";#d#
622 root 1.1 if (length $self->{buf} >= $self->{datalen}) {
623 root 1.11 $self->rcv_data (substr $self->{buf}, 0, delete $self->{datalen}, "");
624 root 1.1 } else {
625     last;
626     }
627 root 1.5 } elsif ($self->{buf} =~ s/^DataChunk\015?\012Length=([0-9a-fA-F]+)\015?\012Data\015?\012//) {
628     $self->{datalen} = hex $1;
629 root 1.13 #warn "expecting new datachunk $self->{datalen}\n";#d#
630 root 1.7 } elsif ($self->{buf} =~ s/^([a-zA-Z]+)\015?\012(?:(.+?)\015?\012)?EndMessage\015?\012//s) {
631 root 1.2 $self->rcv ($1, {
632     map { my ($a, $b) = split /=/, $_, 2; ((Net::FCP::tolc $a), $b) }
633     split /\015?\012/, $2
634     });
635 root 1.1 } else {
636     last;
637     }
638     }
639     } else {
640     $self->eof;
641     }
642     }
643    
644     sub rcv {
645     my ($self, $type, $attr) = @_;
646    
647 root 1.2 $type = Net::FCP::tolc $type;
648    
649 root 1.5 #use PApp::Util; warn PApp::Util::dumpval [$type, $attr];
650    
651 root 1.2 if (my $method = $self->can("rcv_$type")) {
652 root 1.1 $method->($self, $attr, $type);
653     } else {
654     warn "received unexpected reply type '$type' for '$self->{type}', ignoring\n";
655     }
656     }
657    
658 root 1.12 # used as a default exception thrower
659     sub rcv_throw_exception {
660     my ($self, $attr, $type) = @_;
661 root 1.15 $self->throw (Net::FCP::Exception->new ($type, $attr));
662 root 1.12 }
663    
664     *rcv_failed = \&Net::FCP::Txn::rcv_throw_exception;
665     *rcv_format_error = \&Net::FCP::Txn::rcv_throw_exception;
666    
667 root 1.9 sub throw {
668     my ($self, $exc) = @_;
669    
670     $self->{exception} = $exc;
671 root 1.17 $self->set_result;
672 root 1.12 $self->eof; # must be last to avoid loops
673 root 1.9 }
674    
675 root 1.5 sub set_result {
676 root 1.1 my ($self, $result) = @_;
677    
678 root 1.12 unless (exists $self->{result}) {
679     $self->{result} = $result;
680     $self->{cb}->($self) if exists $self->{cb};
681     $self->{signal}->send;
682     }
683 root 1.1 }
684    
685 root 1.5 sub eof {
686     my ($self) = @_;
687 root 1.12
688     delete $self->{w};
689     delete $self->{fh};
690    
691     delete $self->{fcp}{txn}{$self};
692    
693 root 1.17 unless (exists $self->{result}) {
694     $self->throw (Net::FCP::Exception->new (short_data => {
695     reason => "unexpected eof or internal node error",
696     }));
697     }
698 root 1.5 }
699    
700 root 1.9 sub progress {
701     my ($self, $type, $attr) = @_;
702 root 1.27
703 root 1.9 $self->{fcp}->progress ($self, $type, $attr);
704     }
705    
706 root 1.1 =item $result = $txn->result
707    
708     Waits until a result is available and then returns it.
709    
710 root 1.5 This waiting is (depending on your event model) not very efficient, as it
711 root 1.23 is done outside the "mainloop". The biggest problem, however, is that it's
712     blocking one thread of execution. Try to use the callback mechanism, if
713     possible, and call result from within the callback (or after is has been
714     run), as then no waiting is necessary.
715 root 1.1
716     =cut
717    
718     sub result {
719     my ($self) = @_;
720    
721 root 1.12 $self->{signal}->wait while !exists $self->{result};
722 root 1.9
723     die $self->{exception} if $self->{exception};
724 root 1.1
725     return $self->{result};
726     }
727    
728     package Net::FCP::Txn::ClientHello;
729    
730     use base Net::FCP::Txn;
731    
732 root 1.2 sub rcv_node_hello {
733 root 1.1 my ($self, $attr) = @_;
734    
735 root 1.5 $self->set_result ($attr);
736 root 1.1 }
737    
738     package Net::FCP::Txn::ClientInfo;
739    
740     use base Net::FCP::Txn;
741    
742 root 1.2 sub rcv_node_info {
743 root 1.1 my ($self, $attr) = @_;
744    
745 root 1.5 $self->set_result ($attr);
746 root 1.1 }
747    
748     package Net::FCP::Txn::GenerateCHK;
749    
750     use base Net::FCP::Txn;
751    
752     sub rcv_success {
753     my ($self, $attr) = @_;
754    
755 root 1.21 $self->set_result ($attr->{uri});
756 root 1.1 }
757    
758     package Net::FCP::Txn::GenerateSVKPair;
759    
760     use base Net::FCP::Txn;
761    
762     sub rcv_success {
763     my ($self, $attr) = @_;
764 root 1.5 $self->set_result ([$attr->{PublicKey}, $attr->{PrivateKey}]);
765 root 1.1 }
766    
767 root 1.17 package Net::FCP::Txn::InsertPrivateKey;
768 root 1.1
769     use base Net::FCP::Txn;
770    
771     sub rcv_success {
772     my ($self, $attr) = @_;
773 root 1.5 $self->set_result ($attr->{PublicKey});
774 root 1.1 }
775    
776     package Net::FCP::Txn::GetSize;
777    
778     use base Net::FCP::Txn;
779    
780     sub rcv_success {
781     my ($self, $attr) = @_;
782 root 1.23 $self->set_result (hex $attr->{Length});
783 root 1.5 }
784    
785 root 1.12 package Net::FCP::Txn::GetPut;
786    
787     # base class for get and put
788    
789     use base Net::FCP::Txn;
790    
791 root 1.27 *rcv_uri_error = \&Net::FCP::Txn::rcv_throw_exception;
792     *rcv_route_not_found = \&Net::FCP::Txn::rcv_throw_exception;
793 root 1.12
794     sub rcv_restarted {
795     my ($self, $attr, $type) = @_;
796    
797     delete $self->{datalength};
798     delete $self->{metalength};
799     delete $self->{data};
800    
801     $self->progress ($type, $attr);
802     }
803    
804 root 1.5 package Net::FCP::Txn::ClientGet;
805    
806 root 1.12 use base Net::FCP::Txn::GetPut;
807    
808     *rcv_data_not_found = \&Net::FCP::Txn::rcv_throw_exception;
809 root 1.5
810 root 1.17 sub rcv_data {
811     my ($self, $chunk) = @_;
812 root 1.9
813 root 1.17 $self->{data} .= $chunk;
814 root 1.5
815 root 1.19 $self->progress ("data", { chunk => length $chunk, received => length $self->{data}, total => $self->{datalength} });
816 root 1.9
817 root 1.12 if ($self->{datalength} == length $self->{data}) {
818     my $data = delete $self->{data};
819     my $meta = Net::FCP::parse_metadata substr $data, 0, $self->{metalength}, "";
820    
821     $self->set_result ([$meta, $data]);
822 root 1.22 $self->eof;
823 root 1.12 }
824 root 1.9 }
825    
826 root 1.17 sub rcv_data_found {
827     my ($self, $attr, $type) = @_;
828    
829     $self->progress ($type, $attr);
830    
831     $self->{datalength} = hex $attr->{data_length};
832     $self->{metalength} = hex $attr->{metadata_length};
833     }
834    
835 root 1.12 package Net::FCP::Txn::ClientPut;
836 root 1.9
837 root 1.12 use base Net::FCP::Txn::GetPut;
838 root 1.9
839 root 1.12 *rcv_size_error = \&Net::FCP::Txn::rcv_throw_exception;
840     *rcv_key_collision = \&Net::FCP::Txn::rcv_throw_exception;
841 root 1.9
842 root 1.12 sub rcv_pending {
843 root 1.9 my ($self, $attr, $type) = @_;
844     $self->progress ($type, $attr);
845 root 1.5 }
846    
847 root 1.12 sub rcv_success {
848     my ($self, $attr, $type) = @_;
849     $self->set_result ($attr);
850 root 1.9 }
851    
852 root 1.17 =back
853    
854     =head2 The Net::FCP::Exception CLASS
855    
856     Any unexpected (non-standard) responses that make it impossible to return
857     the advertised result will result in an exception being thrown when the
858     C<result> method is called.
859    
860     These exceptions are represented by objects of this class.
861    
862     =over 4
863    
864     =cut
865    
866 root 1.9 package Net::FCP::Exception;
867    
868     use overload
869     '""' => sub {
870 root 1.22 "Net::FCP::Exception<<$_[0][0]," . (join ":", %{$_[0][1]}) . ">>";
871 root 1.9 };
872    
873 root 1.17 =item $exc = new Net::FCP::Exception $type, \%attr
874    
875     Create a new exception object of the given type (a string like
876     C<route_not_found>), and a hashref containing additional attributes
877     (usually the attributes of the message causing the exception).
878    
879     =cut
880    
881 root 1.9 sub new {
882     my ($class, $type, $attr) = @_;
883    
884 root 1.12 bless [Net::FCP::tolc $type, { %$attr }], $class;
885 root 1.17 }
886    
887     =item $exc->type([$type])
888    
889     With no arguments, returns the exception type. Otherwise a boolean
890     indicating wether the exception is of the given type is returned.
891    
892     =cut
893    
894     sub type {
895     my ($self, $type) = @_;
896    
897     @_ >= 2
898     ? $self->[0] eq $type
899     : $self->[0];
900     }
901    
902     =item $exc->attr([$attr])
903    
904     With no arguments, returns the attributes. Otherwise the named attribute
905     value is returned.
906    
907     =cut
908    
909     sub attr {
910     my ($self, $attr) = @_;
911    
912     @_ >= 2
913     ? $self->[1]{$attr}
914     : $self->[1];
915 root 1.1 }
916    
917     =back
918    
919     =head1 SEE ALSO
920    
921     L<http://freenet.sf.net>.
922    
923     =head1 BUGS
924    
925     =head1 AUTHOR
926    
927     Marc Lehmann <pcg@goof.com>
928     http://www.goof.com/pcg/marc/
929    
930     =cut
931 root 1.20
932     package Net::FCP::Event::Auto;
933    
934     my @models = (
935 root 1.27 [Coro => Coro::Event::],
936 root 1.20 [Event => Event::],
937 root 1.27 [Glib => Glib::],
938 root 1.20 [Tk => Tk::],
939     );
940    
941     sub AUTOLOAD {
942     $AUTOLOAD =~ s/.*://;
943    
944     for (@models) {
945     my ($model, $package) = @$_;
946     if (defined ${"$package\::VERSION"}) {
947     $EVENT = "Net::FCP::Event::$model";
948     eval "require $EVENT"; die if $@;
949     goto &{"$EVENT\::$AUTOLOAD"};
950     }
951     }
952    
953     for (@models) {
954     my ($model, $package) = @$_;
955     $EVENT = "Net::FCP::Event::$model";
956     if (eval "require $EVENT") {
957     goto &{"$EVENT\::$AUTOLOAD"};
958     }
959     }
960    
961     die "No event module selected for Net::FCP and autodetect failed. Install any of these: Coro, Event, Glib or Tk.";
962     }
963 root 1.1
964     1;
965