File Coverage

blib/lib/AnyEvent/FCP.pm
Criterion Covered Total %
statement 23 136 16.9
branch 0 36 0.0
condition 0 25 0.0
subroutine 7 29 24.1
pod 1 10 10.0
total 31 236 13.1


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             AnyEvent::FCP - freenet client protocol 2.0
4              
5             =head1 SYNOPSIS
6              
7             use AnyEvent::FCP;
8              
9             my $fcp = new AnyEvent::FCP;
10              
11             # transactions return condvars
12             my $lp_cv = $fcp->list_peers;
13             my $pr_cv = $fcp->list_persistent_requests;
14              
15             my $peers = $lp_cv->recv;
16             my $reqs = $pr_cv->recv;
17              
18             =head1 DESCRIPTION
19              
20             This module implements the freenet client protocol version 2.0, as used by
21             freenet 0.7. See L for the earlier freenet 0.5 version.
22              
23             See L for a
24             description of what the messages do.
25              
26             The module uses L to find a suitable event module.
27              
28             Only very little is implemented, ask if you need more, and look at the
29             example program later in this section.
30              
31             =head2 EXAMPLE
32              
33             This example fetches the download list and sets the priority of all files
34             with "a" in their name to "emergency":
35              
36             use AnyEvent::FCP;
37              
38             my $fcp = new AnyEvent::FCP;
39              
40             $fcp->watch_global (1, 0);
41             my $req = $fcp->list_persistent_requests;
42              
43             TODO
44             for my $req (values %$req) {
45             if ($req->{filename} =~ /a/) {
46             $fcp->modify_persistent_request (1, $req->{identifier}, undef, 0);
47             }
48             }
49              
50             =head2 IMPORT TAGS
51              
52             Nothing much can be "imported" from this module right now.
53              
54             =head1 THE AnyEvent::FCP CLASS
55              
56             =over 4
57              
58             =cut
59              
60             package AnyEvent::FCP;
61              
62 1     1   1560 use common::sense;
  1         9  
  1         5  
63              
64 1     1   50 use Carp;
  1         2  
  1         101  
65              
66             our $VERSION = 0.4;
67              
68 1     1   5 use Scalar::Util ();
  1         4  
  1         19  
69              
70 1     1   3311 use AnyEvent;
  1         5999  
  1         40  
71 1     1   1183 use AnyEvent::Handle;
  1         25608  
  1         44  
72 1     1   10 use AnyEvent::Util ();
  1         2  
  1         6225  
73              
74             our %TOLC; # tolc cache
75              
76             sub touc($) {
77 0     0 0 0 local $_ = shift;
78 0         0 1 while s/((?:^|_)(?:svk|chk|uri|fcp|ds|mime|dda)(?:_|$))/\U$1/;
79 0         0 s/(?:^|_)(.)/\U$1/g;
80 0         0 $_
81             }
82              
83             sub tolc($) {
84 0     0 0 0 local $_ = shift;
85 0         0 1 while s/(SVK|CHK|URI|FCP|DS|MIME|DDA)([^_])/$1\_$2/;
86 0         0 1 while s/([^_])(SVK|CHK|URI|FCP|DS|MIME|DDA)/$1\_$2/;
87 0         0 s/(?<=[a-z])(?=[A-Z])/_/g;
88             lc
89 0         0 }
90              
91             =item $fcp = new AnyEvent::FCP [host => $host][, port => $port][, name => $name]
92              
93             Create a new FCP connection to the given host and port (default
94             127.0.0.1:9481, or the environment variables C and C).
95              
96             If no C was specified, then AnyEvent::FCP will generate a
97             (hopefully) unique client name for you.
98              
99             =cut
100              
101             sub new {
102 0     0 1 0 my $class = shift;
103              
104 0         0 my $rand = join "", map chr 0x21 + rand 94, 1..40; # ~ 262 bits entropy
105              
106             my $self = bless {
107             host => $ENV{FREDHOST} || "127.0.0.1",
108 0   0     0 port => $ENV{FREDPORT} || 9481,
      0        
109             timeout => 3600 * 2,
110             keepalive => 9 * 60,
111             name => time.rand.rand.rand, # lame
112             @_,
113             queue => [],
114             req => {},
115             prefix => "..:aefcpid:$rand:",
116             idseq => "a0",
117             }, $class;
118              
119             {
120 0         0 Scalar::Util::weaken (my $self = $self);
  0         0  
121              
122             $self->{kw} = AE::timer $self->{keepalive}, $self->{keepalive}, sub {
123 0     0   0 $self->{hdl}->push_write ("\n");
124 0         0 };
125              
126 0         0 our $ENDMESSAGE = qr<\012(EndMessage|Data)\012>;
127              
128             # these are declared here for performance reasons
129 0         0 my ($k, $v, $type);
130 0         0 my $rdata;
131            
132             my $on_read = sub {
133 0     0   0 my ($hdl) = @_;
134              
135             # we only carve out whole messages here
136 0         0 while ($hdl->{rbuf} =~ /\012(EndMessage|Data)\012/) {
137             # remember end marker
138 0 0 0     0 $rdata = $1 eq "Data"
139             or $1 eq "EndMessage"
140             or die "protocol error, expected message end, got $1\n";
141              
142 0         0 my @lines = split /\012/, substr $hdl->{rbuf}, 0, $-[0];
143              
144 0         0 substr $hdl->{rbuf}, 0, $+[0], ""; # remove pkg
145              
146 0         0 $type = shift @lines;
147 0   0     0 $type = ($TOLC{$type} ||= tolc $type);
148              
149 0         0 my %kv;
150              
151 0         0 for (@lines) {
152 0         0 ($k, $v) = split /=/, $_, 2;
153 0   0     0 $k = ($TOLC{$k} ||= tolc $k);
154            
155 0 0       0 if ($k =~ /\./) {
156             # generic, slow case
157 0         0 my @k = split /\./, $k;
158 0         0 my $ro = \\%kv;
159              
160 0         0 while (@k) {
161 0         0 $k = shift @k;
162 0 0       0 if ($k =~ /^\d+$/) {
163 0         0 $ro = \$$ro->[$k];
164             } else {
165 0         0 $ro = \$$ro->{$k};
166             }
167             }
168              
169 0         0 $$ro = $v;
170              
171 0         0 next;
172             }
173              
174             # special comon case, for performance only
175 0         0 $kv{$k} = $v;
176             }
177            
178 0 0       0 if ($rdata) {
179             $_[0]->push_read (chunk => delete $kv{data_length}, sub {
180 0         0 $rdata = \$_[1];
181 0         0 $self->recv ($type, \%kv, $rdata);
182 0         0 });
183              
184 0         0 last; # do not tgry to parse more messages
185             } else {
186 0         0 $self->recv ($type, \%kv);
187             }
188             }
189 0         0 };
190              
191             $self->{hdl} = new AnyEvent::Handle
192             connect => [$self->{host} => $self->{port}],
193             timeout => $self->{timeout},
194             on_error => sub {
195 0     0   0 warn "$self->{host}: $_[2]\n";#d#
196 0         0 exit 1;
197             },
198             on_read => $on_read,
199       0     on_eof => $self->{on_eof} || sub { },
200 0   0     0 ;
201              
202 0         0 Scalar::Util::weaken ($self->{hdl}{fcp} = $self);
203             }
204              
205             $self->send_msg (client_hello =>
206             name => $self->{name},
207 0         0 expected_version => "2.0",
208             );
209              
210 0         0 $self
211             }
212              
213             sub identifier {
214             $_[0]{prefix} . ++$_[0]{idseq}
215 0     0 0 0 }
216              
217             sub send_msg {
218 0     0 0 0 my ($self, $type, %kv) = @_;
219              
220 0         0 my $data = delete $kv{data};
221              
222 0 0       0 if (exists $kv{id_cb}) {
223 0   0     0 my $id = $kv{identifier} ||= $self->identifier;
224 0         0 $self->{id}{$id} = delete $kv{id_cb};
225             }
226              
227 0         0 my $msg = (touc $type) . "\012"
228             . join "", map +(touc $_) . "=$kv{$_}\012", keys %kv;
229              
230             sub id {
231 0     0 0 0 my ($self) = @_;
232              
233              
234             }
235              
236 0 0       0 if (defined $data) {
237 0         0 $msg .= "DataLength=" . (length $data) . "\012"
238             . "Data\012$data";
239             } else {
240 0         0 $msg .= "EndMessage\012";
241             }
242              
243 0         0 $self->{hdl}->push_write ($msg);
244             }
245              
246             sub on {
247 0     0 0 0 my ($self, $cb) = @_;
248              
249             # cb return undef - message eaten, remove cb
250             # cb return 0 - message eaten
251             # cb return 1 - pass to next
252              
253 0         0 push @{ $self->{on} }, $cb;
  0         0  
254             }
255              
256             sub _push_queue {
257 0     0   0 my ($self, $queue) = @_;
258              
259 0         0 shift @$queue;
260 0     0   0 $queue->[0]($self, AnyEvent::Util::guard { $self->_push_queue ($queue) })
261 0 0       0 if @$queue;
262             }
263              
264             # lock so only one $type (arbitrary string) is in flight,
265             # to work around horribly misdesigned protocol.
266             sub serialise {
267 0     0 0 0 my ($self, $type, $cb) = @_;
268              
269 0   0     0 my $queue = $self->{serialise}{$type} ||= [];
270 0         0 push @$queue, $cb;
271 0     0   0 $cb->($self, AnyEvent::Util::guard { $self->_push_queue ($queue) })
272 0 0       0 unless $#$queue;
273             }
274              
275             # how to merge these types into $self->{persistent}
276             our %PERSISTENT_TYPE = (
277             persistent_get => sub { %{ $_[1] } = (type => "persistent_get" , %{ $_[2] }) },
278             persistent_put => sub { %{ $_[1] } = (type => "persistent_put" , %{ $_[2] }) },
279             persistent_put_dir => sub { %{ $_[1] } = (type => "persistent_put_dir", %{ $_[2] }) },
280             persistent_request_modified => sub { %{ $_[1] } = (%{ $_[1] }, %{ $_[2] }) },
281             persistent_request_removed => sub { delete $_[0]{req}{$_[2]{identifier}} },
282              
283             simple_progress => sub { $_[1]{simple_progress} = $_[2] }, # get/put
284              
285             uri_generated => sub { $_[1]{uri_generated} = $_[2] }, # put
286             generated_metadata => sub { $_[1]{generated_metadata} = $_[2] }, # put
287             started_compression => sub { $_[1]{started_compression} = $_[2] }, # put
288             finished_compression => sub { $_[1]{finished_compression} = $_[2] }, # put
289             put_fetchable => sub { $_[1]{put_fetchable} = $_[2] }, # put
290             put_failed => sub { $_[1]{put_failed} = $_[2] }, # put
291             put_successful => sub { $_[1]{put_successful} = $_[2] }, # put
292              
293             sending_to_network => sub { $_[1]{sending_to_network} = $_[2] }, # get
294             compatibility_mode => sub { $_[1]{compatibility_mode} = $_[2] }, # get
295             expected_hashes => sub { $_[1]{expected_hashes} = $_[2] }, # get
296             expected_mime => sub { $_[1]{expected_mime} = $_[2] }, # get
297             expected_data_length => sub { $_[1]{expected_data_length} = $_[2] }, # get
298             get_failed => sub { $_[1]{get_failed} = $_[2] }, # get
299             data_found => sub { $_[1]{data_found} = $_[2] }, # get
300             enter_finite_cooldown => sub { $_[1]{enter_finite_cooldown} = $_[2] }, # get
301             );
302              
303             sub recv {
304 0     0 0 0 my ($self, $type, $kv, @extra) = @_;
305              
306 0 0       0 if (my $cb = $PERSISTENT_TYPE{$type}) {
307 0         0 my $id = $kv->{identifier};
308 0   0     0 my $req = $_[0]{req}{$id} ||= {};
309 0         0 $cb->($self, $req, $kv);
310 0         0 $self->recv (request_changed => $kv, $type, @extra);
311             }
312              
313 0         0 my $on = $self->{on};
314 0         0 for (0 .. $#$on) {
315 0 0       0 unless (my $res = $on->[$_]($self, $type, $kv, @extra)) {
316 0 0       0 splice @$on, $_, 1 unless defined $res;
317 0         0 return;
318             }
319             }
320              
321 0 0       0 if (my $cb = $self->{queue}[0]) {
322             $cb->($self, $type, $kv, @extra)
323 0 0       0 and shift @{ $self->{queue} };
  0         0  
324             } else {
325 0         0 $self->default_recv ($type, $kv, @extra);
326             }
327             }
328              
329             sub default_recv {
330 0     0 0 0 my ($self, $type, $kv, $rdata) = @_;
331              
332 0 0       0 if ($type eq "node_hello") {
    0          
333 0         0 $self->{node_hello} = $kv;
334             } elsif (exists $self->{id}{$kv->{identifier}}) {
335             $self->{id}{$kv->{identifier}}($self, $type, $kv, $rdata)
336 0 0       0 and delete $self->{id}{$kv->{identifier}};
337             }
338             }
339              
340             =back
341              
342             =head2 FCP REQUESTS
343              
344             The following methods implement various requests. Most of them map
345             directory to the FCP message of the same name. The added benefit of
346             these over sending requests yourself is that they handle the necessary
347             serialisation, protocol quirks, and replies.
348              
349             All of them exist in two versions, the variant shown in this manpage, and
350             a variant with an extra C<_> at the end, and an extra C<$cb> argument. The
351             version as shown is I - it will wait for any replies, and
352             either return the reply, or croak with an error. The underscore variant
353             returns immediately and invokes one or more callbacks or condvars later.
354              
355             For example, the call
356              
357             $info = $fcp->get_plugin_info ($name, $detailed);
358              
359             Also comes in this underscore variant:
360              
361             $fcp->get_plugin_info_ ($name, $detailed, $cb);
362              
363             You can thinbk of the underscore as a kind of continuation indicator - the
364             normal function waits and returns with the data, the C<_> indicates that
365             you pass the continuation yourself, and the continuation will be invoked
366             with the results.
367              
368             This callback/continuation argument (C<$cb>) can come in three forms itself:
369              
370             =over 4
371              
372             =item A code reference (or rather anything not matching some other alternative)
373              
374             This code reference will be invoked with the result on success. On an
375             error, it will die (in the event loop) with a backtrace of the call site.
376              
377             This is a popular choice, but it makes handling errors hard - make sure
378             you never generate protocol errors!
379              
380             =item A condvar (as returned by e.g. C<< AnyEvent->condvar >>)
381              
382             When a condvar is passed, it is sent (C<< $cv->send ($results) >>) the
383             results when the request has finished. Should an error occur, the error
384             will instead result in C<< $cv->croak ($error) >>.
385              
386             This is also a popular choice.
387              
388             =item An array with two callbacks C<[$success, $failure]>
389              
390             The C<$success> callback will be invoked with the results, while the
391             C<$failure> callback will be invoked on any errors.
392              
393             =item C
394              
395             This is the same thing as specifying C as callback, i.e. on
396             success, the results are ignored, while on failure, you the module dies
397             with a backtrace.
398              
399             This is good for quick scripts, or when you really aren't interested in
400             the results.
401              
402             =back
403              
404             =cut
405              
406             our $NOP_CB = sub { };
407              
408             sub _txn {
409 9     9   16 my ($name, $sub) = @_;
410              
411 9         36 *{$name} = sub {
412 0     0   0 my $cv = AE::cv;
413              
414 0     0   0 splice @_, 1, 0, $cv, sub { $cv->croak ($_[0]{extra_description}) };
  0         0  
415 0         0 &$sub;
416 0         0 $cv->recv
417 9         36 };
418              
419 9         47 *{"$name\_"} = sub {
420 0     0     my ($ok, $err) = pop;
421              
422 0 0         if (ARRAY:: eq ref $ok) {
    0          
423 0           ($ok, $err) = @$ok;
424             } elsif (UNIVERSAL::isa $ok, AnyEvent::CondVar::) {
425 0     0     $err = sub { $ok->croak ($_[0]{extra_description}) };
  0            
426             } else {
427 0           my $bt = Carp::longmess "";
428             $err = sub {
429 0     0     die "$_[0]{code_description} ($_[0]{extra_description})$bt";
430 0           };
431             }
432              
433 0   0       $ok ||= $NOP_CB;
434              
435 0           splice @_, 1, 0, $ok, $err;
436 0           &$sub;
437 9         38 };
438             }
439              
440             =over 4
441              
442             =item $peers = $fcp->list_peers ([$with_metdata[, $with_volatile]])
443              
444             =cut
445              
446             _txn list_peers => sub {
447             my ($self, $ok, undef, $with_metadata, $with_volatile) = @_;
448              
449             my @res;
450              
451             $self->send_msg (list_peers =>
452             with_metadata => $with_metadata ? "true" : "false",
453             with_volatile => $with_volatile ? "true" : "false",
454             id_cb => sub {
455             my ($self, $type, $kv, $rdata) = @_;
456              
457             if ($type eq "end_list_peers") {
458             $ok->(\@res);
459             1
460             } else {
461             push @res, $kv;
462             0
463             }
464             },
465             );
466             };
467              
468             =item $notes = $fcp->list_peer_notes ($node_identifier)
469              
470             =cut
471              
472             _txn list_peer_notes => sub {
473             my ($self, $ok, undef, $node_identifier) = @_;
474              
475             $self->send_msg (list_peer_notes =>
476             node_identifier => $node_identifier,
477             id_cb => sub {
478             my ($self, $type, $kv, $rdata) = @_;
479              
480             $ok->($kv);
481             1
482             },
483             );
484             };
485              
486             =item $fcp->watch_global ($enabled[, $verbosity_mask])
487              
488             =cut
489              
490             _txn watch_global => sub {
491             my ($self, $ok, $err, $enabled, $verbosity_mask) = @_;
492              
493             $self->send_msg (watch_global =>
494             enabled => $enabled ? "true" : "false",
495             defined $verbosity_mask ? (verbosity_mask => $verbosity_mask+0) : (),
496             );
497              
498             $ok->();
499             };
500              
501             =item $reqs = $fcp->list_persistent_requests
502              
503             =cut
504              
505             _txn list_persistent_requests => sub {
506             my ($self, $ok, $err) = @_;
507              
508             $self->serialise (list_persistent_requests => sub {
509             my ($self, $guard) = @_;
510              
511             my @res;
512              
513             $self->send_msg ("list_persistent_requests");
514              
515             $self->on (sub {
516             my ($self, $type, $kv, $rdata) = @_;
517              
518             $guard if 0;
519              
520             if ($type eq "end_list_persistent_requests") {
521             $ok->(\@res);
522             return;
523             } else {
524             my $id = $kv->{identifier};
525              
526             if ($type =~ /^persistent_(get|put|put_dir)$/) {
527             push @res, [$type, $kv];
528             }
529             }
530              
531             1
532             });
533             });
534             };
535              
536             =item $sync = $fcp->modify_persistent_request ($global, $identifier[, $client_token[, $priority_class]])
537              
538             Update either the C or C of a request
539             identified by C<$global> and C<$identifier>, depending on which of
540             C<$client_token> and C<$priority_class> are not C.
541              
542             =cut
543              
544             _txn modify_persistent_request => sub {
545             my ($self, $ok, $err, $global, $identifier, $client_token, $priority_class) = @_;
546              
547             $self->serialise ($identifier => sub {
548             my ($self, $guard) = @_;
549              
550             $self->send_msg (modify_persistent_request =>
551             global => $global ? "true" : "false",
552             identifier => $identifier,
553             defined $client_token ? (client_token => $client_token ) : (),
554             defined $priority_class ? (priority_class => $priority_class) : (),
555             );
556              
557             $self->on (sub {
558             my ($self, $type, $kv, @extra) = @_;
559              
560             $guard if 0;
561              
562             if ($kv->{identifier} eq $identifier) {
563             if ($type eq "persistent_request_modified") {
564             $ok->($kv);
565             return;
566             } elsif ($type eq "protocol_error") {
567             $err->($kv);
568             return;
569             }
570             }
571              
572             1
573             });
574             });
575             };
576              
577             =item $info = $fcp->get_plugin_info ($name, $detailed)
578              
579             =cut
580              
581             _txn get_plugin_info => sub {
582             my ($self, $ok, $err, $name, $detailed) = @_;
583              
584             my $id = $self->identifier;
585              
586             $self->send_msg (get_plugin_info =>
587             identifier => $id,
588             plugin_name => $name,
589             detailed => $detailed ? "true" : "false",
590             );
591             $self->on (sub {
592             my ($self, $type, $kv) = @_;
593              
594             if ($kv->{identifier} eq $id) {
595             if ($type eq "get_plugin_info") {
596             $ok->($kv);
597             } else {
598             $err->($kv, $type);
599             }
600             return;
601             }
602              
603             1
604             });
605             };
606              
607             =item $status = $fcp->client_get ($uri, $identifier, %kv)
608              
609             %kv can contain (L).
610              
611             ignore_ds, ds_only, verbosity, max_size, max_temp_size, max_retries,
612             priority_class, persistence, client_token, global, return_type,
613             binary_blob, allowed_mime_types, filename, temp_filename
614              
615             =cut
616              
617             _txn client_get => sub {
618             my ($self, $ok, $err, $uri, $identifier, %kv) = @_;
619              
620             $self->serialise ($identifier => sub {
621             my ($self, $guard) = @_;
622              
623             $self->send_msg (client_get =>
624             %kv,
625             uri => $uri,
626             identifier => $identifier,
627             );
628              
629             $self->on (sub {
630             my ($self, $type, $kv, @extra) = @_;
631              
632             $guard if 0;
633              
634             if ($kv->{identifier} eq $identifier) {
635             if ($type eq "persistent_get") {
636             $ok->($kv);
637             return;
638             } elsif ($type eq "protocol_error") {
639             $err->($kv);
640             return;
641             }
642             }
643              
644             1
645             });
646             });
647             };
648              
649             =item $status = $fcp->remove_request ($identifier[, $global])
650              
651             Remove the request with the given isdentifier. Returns true if successful,
652             false on error.
653              
654             =cut
655              
656             _txn remove_request => sub {
657             my ($self, $ok, $err, $identifier, $global) = @_;
658              
659             $self->serialise ($identifier => sub {
660             my ($self, $guard) = @_;
661              
662             $self->send_msg (remove_request =>
663             identifier => $identifier,
664             global => $global ? "true" : "false",
665             );
666             $self->on (sub {
667             my ($self, $type, $kv, @extra) = @_;
668              
669             $guard if 0;
670              
671             if ($kv->{identifier} eq $identifier) {
672             if ($type eq "persistent_request_removed") {
673             $ok->(1);
674             return;
675             } elsif ($type eq "protocol_error") {
676             $err->($kv);
677             return;
678             }
679             }
680              
681             1
682             });
683             });
684             };
685              
686             =item ($can_read, $can_write) = $fcp->test_dda ($local_directory, $remote_directory, $want_read, $want_write))
687              
688             The DDA test in FCP is probably the single most broken protocol - only
689             one directory test can be outstanding at any time, and some guessing and
690             heuristics are involved in mangling the paths.
691              
692             This function combines C and C in one
693             request, handling file reading and writing as well, and tries very hard to
694             do the right thing.
695              
696             Both C<$local_directory> and C<$remote_directory> must specify the same
697             directory - C<$local_directory> is the directory path on the client (where
698             L runs) and C<$remote_directory> is the directory path on
699             the server (where the freenet node runs). When both are running on the
700             same node, the paths are generally identical.
701              
702             C<$want_read> and C<$want_write> should be set to a true value when you
703             want to read (get) files or write (put) files, respectively.
704              
705             On error, an exception is thrown. Otherwise, C<$can_read> and
706             C<$can_write> indicate whether you can reaqd or write to freenet via the
707             directory.
708              
709             =cut
710              
711             _txn test_dda => sub {
712             my ($self, $ok, $err, $local, $remote, $want_read, $want_write) = @_;
713              
714             $self->serialise (test_dda => sub {
715             my ($self, $guard) = @_;
716              
717             $self->send_msg (test_dda_request =>
718             directory => $remote,
719             want_read_directory => $want_read ? "true" : "false",
720             want_write_directory => $want_write ? "true" : "false",
721             );
722             $self->on (sub {
723             my ($self, $type, $kv) = @_;
724              
725             if ($type eq "test_dda_reply") {
726             # the filenames are all relative to the server-side directory,
727             # which might or might not match $remote anymore, so we
728             # need to rewrite the paths to be relative to $local
729             for my $k (qw(read_filename write_filename)) {
730             my $f = $kv->{$k};
731             for my $dir ($kv->{directory}, $remote) {
732             if ($dir eq substr $f, 0, length $dir) {
733             substr $f, 0, 1 + length $dir, "";
734             $kv->{$k} = $f;
735             last;
736             }
737             }
738             }
739              
740             my %response = (directory => $remote);
741              
742             if (length $kv->{read_filename}) {
743             if (open my $fh, "<:raw", "$local/$kv->{read_filename}") {
744             sysread $fh, my $buf, -s $fh;
745             $response{read_content} = $buf;
746             }
747             }
748              
749             if (length $kv->{write_filename}) {
750             if (open my $fh, ">:raw", "$local/$kv->{write_filename}") {
751             syswrite $fh, $kv->{content_to_write};
752             }
753             }
754              
755             $self->send_msg (test_dda_response => %response);
756              
757             $self->on (sub {
758             my ($self, $type, $kv) = @_;
759              
760             $guard if 0; # reference
761              
762             if ($type eq "test_dda_complete") {
763             $ok->(
764             $kv->{read_directory_allowed} eq "true",
765             $kv->{write_directory_allowed} eq "true",
766             );
767             } elsif ($type eq "protocol_error" && $kv->{identifier} eq $remote) {
768             $err->($kv->{extra_description});
769             return;
770             }
771              
772             1
773             });
774              
775             return;
776             } elsif ($type eq "protocol_error" && $kv->{identifier} eq $remote) {
777             $err->($kv);
778             return;
779             }
780              
781             1
782             });
783             });
784             };
785              
786             =back
787              
788             =head2 REQUEST CACHE
789              
790             The C class keeps a request cache, where it caches all
791             information from requests.
792              
793             For these messages, it will store a copy of the key-value pairs, together with a C slot,
794             in C<< $fcp->{req}{$identifier} >>:
795              
796             persistent_get
797             persistent_put
798             persistent_put_dir
799              
800             This message updates the stored data:
801              
802             persistent_request_modified
803              
804             This message will remove this entry:
805              
806             persistent_request_removed
807              
808             These messages get merged into the cache entry, under their
809             type, i.e. a C message will be stored in C<<
810             $fcp->{req}{$identifier}{simple_progress} >>:
811              
812             simple_progress # get/put
813              
814             uri_generated # put
815             generated_metadata # put
816             started_compression # put
817             finished_compression # put
818             put_failed # put
819             put_fetchable # put
820             put_successful # put
821              
822             sending_to_network # get
823             compatibility_mode # get
824             expected_hashes # get
825             expected_mime # get
826             expected_data_length # get
827             get_failed # get
828             data_found # get
829             enter_finite_cooldown # get
830              
831             In addition, an event (basically a fake message) of type C is generated
832             on every change, which will be called as C<< $cb->($fcp, $kv, $type) >>, where C<$type>
833             is the type of the original message triggering the change,
834              
835             To fill this cache with the global queue and keep it updated,
836             call C to subscribe to updates, followed by
837             C.
838              
839             $fcp->watch_global_sync_; # do not wait
840             $fcp->list_persistent_requests; # wait
841              
842             To get a better idea of what is stored in the cache, here is an example of
843             what might be stored in C<< $fcp->{req}{"Frost-gpl.txt"} >>:
844              
845             {
846             identifier => "Frost-gpl.txt",
847             uri => 'CHK@Fnx5kzdrfE,EImdzaVyEWl,AAIC--8/gpl.txt',
848             binary_blob => "false",
849             global => "true",
850             max_retries => -1,
851             max_size => 9223372036854775807,
852             persistence => "forever",
853             priority_class => 3,
854             real_time => "false",
855             return_type => "direct",
856             started => "true",
857             type => "persistent_get",
858             verbosity => 2147483647,
859             sending_to_network => {
860             identifier => "Frost-gpl.txt",
861             global => "true",
862             },
863             compatibility_mode => {
864             identifier => "Frost-gpl.txt",
865             definitive => "true",
866             dont_compress => "false",
867             global => "true",
868             max => "COMPAT_1255",
869             min => "COMPAT_1255",
870             },
871             expected_hashes => {
872             identifier => "Frost-gpl.txt",
873             global => "true",
874             hashes => {
875             ed2k => "d83596f5ee3b7...",
876             md5 => "e0894e4a2a6...",
877             sha1 => "...",
878             sha256 => "...",
879             sha512 => "...",
880             tth => "...",
881             },
882             },
883             expected_mime => {
884             identifier => "Frost-gpl.txt",
885             global => "true",
886             metadata => { content_type => "application/rar" },
887             },
888             expected_data_length => {
889             identifier => "Frost-gpl.txt",
890             data_length => 37576,
891             global => "true",
892             },
893             simple_progress => {
894             identifier => "Frost-gpl.txt",
895             failed => 0,
896             fatally_failed => 0,
897             finalized_total => "true",
898             global => "true",
899             last_progress => 1438639282628,
900             required => 372,
901             succeeded => 102,
902             total => 747,
903             },
904             data_found => {
905             identifier => "Frost-gpl.txt",
906             completion_time => 1438663354026,
907             data_length => 37576,
908             global => "true",
909             metadata => { content_type => "image/jpeg" },
910             startup_time => 1438657196167,
911             },
912             }
913              
914             =head1 EXAMPLE PROGRAM
915              
916             use AnyEvent::FCP;
917              
918             my $fcp = new AnyEvent::FCP;
919              
920             # let us look at the global request list
921             $fcp->watch_global_ (1);
922              
923             # list them, synchronously
924             my $req = $fcp->list_persistent_requests;
925              
926             # go through all requests
927             TODO
928             for my $req (values %$req) {
929             # skip jobs not directly-to-disk
930             next unless $req->{return_type} eq "disk";
931             # skip jobs not issued by FProxy
932             next unless $req->{identifier} =~ /^FProxy:/;
933              
934             if ($req->{data_found}) {
935             # file has been successfully downloaded
936            
937             ... move the file away
938             (left as exercise)
939              
940             # remove the request
941              
942             $fcp->remove_request (1, $req->{identifier});
943             } elsif ($req->{get_failed}) {
944             # request has failed
945             if ($req->{get_failed}{code} == 11) {
946             # too many path components, should restart
947             } else {
948             # other failure
949             }
950             } else {
951             # modify priorities randomly, to improve download rates
952             $fcp->modify_persistent_request (1, $req->{identifier}, undef, int 6 - 5 * (rand) ** 1.7)
953             if 0.1 > rand;
954             }
955             }
956              
957             # see if the dummy plugin is loaded, to ensure all previous requests have finished.
958             $fcp->get_plugin_info_sync ("dummy");
959              
960             =head1 SEE ALSO
961              
962             L, L.
963              
964             =head1 BUGS
965              
966             =head1 AUTHOR
967              
968             Marc Lehmann
969             http://home.schmorp.de/
970              
971             =cut
972              
973             1
974