ViewVC Help

View File | Revision Log | Show Annotations | Download File

/cvs/AnyEvent-FCP/FCP.pm

Comparing AnyEvent-FCP/FCP.pm (file contents):
Revision 1.1 by root, Sat Jul 18 05:57:59 2009 UTC vs.
Revision 1.18 by root, Thu Dec 3 19:07:57 2015 UTC

…		…
2		2
3	AnyEvent::FCP - freenet client protocol 2.0	3	AnyEvent::FCP - freenet client protocol 2.0
4		4
5	=head1 SYNOPSIS	5	=head1 SYNOPSIS
6		6
7	use AnyEvent::FCP;	7	use AnyEvent::FCP;
8		8
9	my $fcp = new AnyEvent::FCP;	9	my $fcp = new AnyEvent::FCP;
10		10
11	my $ni = $fcp->txn_node_info->result;	11	# transactions return condvars
12	my $ni = $fcp->node_info;	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;
13		17
14	=head1 DESCRIPTION	18	=head1 DESCRIPTION
15		19
16	This module implements the freenet client protocol version 2.0, as used by	20	This module implements the freenet client protocol version 2.0, as used by
17	freenet 0.7. See L<Net::FCP> for the earlier freenet 0.5 version.	21	freenet 0.7. See L<Net::FCP> for the earlier freenet 0.5 version.
18		22
19	See L<http://wiki.freenetproject.org/FreenetFCPSpec2Point0> for a description	23	See L<http://wiki.freenetproject.org/FreenetFCPSpec2Point0> for a
20	of what the messages do.	24	description of what the messages do.
21		25
22	The module uses L<AnyEvent> to find a suitable event module.	26	The module uses L<AnyEvent> to find a suitable event module.
23		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
24	=head2 IMPORT TAGS	50	=head2 IMPORT TAGS
25		51
26	Nothing much can be "imported" from this module right now.	52	Nothing much can be "imported" from this module right now.
27		53
28	=head2 FREENET BASICS	54	=head1 THE AnyEvent::FCP CLASS
29
30	Ok, this section will not explain any freenet basics to you, just some
31	problems I found that you might want to avoid:
32		55
33	=over 4	56	=over 4
34		57
35	=item freenet URIs are _NOT_ URIs
36
37	Whenever a "uri" is required by the protocol, freenet expects a kind of
38	URI prefixed with the "freenet:" scheme, e.g. "freenet:CHK...". However,
39	these are not URIs, as freeent fails to parse them correctly, that is, you
40	must unescape an escaped characters ("%2c" => ",") yourself. Maybe in the
41	future this library will do it for you, so watch out for this incompatible
42	change.
43
44	=back
45
46	=head2 THE AnyEvent::FCP CLASS
47
48	=over 4
49
50	=cut	58	=cut
51		59
52	package AnyEvent::FCP;	60	package AnyEvent::FCP;
53		61
		62	use common::sense;
		63
54	use Carp;	64	use Carp;
55		65
56	$VERSION = '0.1';	66	our $VERSION = 0.4;
57		67
58	no warnings;	68	use Scalar::Util ();
59		69
60	use AnyEvent;	70	use AnyEvent;
61	use AnyEvent::Socket;	71	use AnyEvent::Handle;
		72	use AnyEvent::Util ();
		73
		74	our %TOLC; # tolc cache
62		75
63	sub touc($) {	76	sub touc($) {
64	local $_ = shift;	77	local $_ = shift;
65	1 while s/((?:^|_)(?:svk|chk|uri)(?:_|$))/\U$1/;	78	1 while s/((?:^|_)(?:svk|chk|uri|fcp|ds|mime|dda)(?:_|$))/\U$1/;
66	s/(?:^|_)(.)/\U$1/g;	79	s/(?:^|_)(.)/\U$1/g;
67	$_	80	$_
68	}	81	}
69		82
70	sub tolc($) {	83	sub tolc($) {
71	local $_ = shift;	84	local $_ = shift;
72	1 while s/(SVK|CHK|URI)([^_])/$1\_$2/i;	85	1 while s/(SVK|CHK|URI|FCP|DS|MIME|DDA)([^_])/$1\_$2/;
73	1 while s/([^_])(SVK|CHK|URI)/$1\_$2/i;	86	1 while s/([^_])(SVK|CHK|URI|FCP|DS|MIME|DDA)/$1\_$2/;
74	s/(?<=[a-z])(?=[A-Z])/_/g;	87	s/(?<=[a-z])(?=[A-Z])/_/g;
75	lc	88	lc
76	}	89	}
77		90
78	=item $fcp = new AnyEvent::FCP [host => $host][, port => $port][, progress => \&cb][, name => $name]	91	=item $fcp = new AnyEvent::FCP [host => $host][, port => $port][, name => $name]
79		92
80	Create a new FCP connection to the given host and port (default	93	Create a new FCP connection to the given host and port (default
81	127.0.0.1:8481, or the environment variables C<FREDHOST> and C<FREDPORT>).	94	127.0.0.1:9481, or the environment variables C<FREDHOST> and C<FREDPORT>).
82		95
83	If no C<name> was specified, then AnyEvent::FCP will generate a (hopefully)	96	If no C<name> was specified, then AnyEvent::FCP will generate a
84	unique client name for you.	97	(hopefully) unique client name for you.
85
86	#TODO
87	#You can install a progress callback that is being called with the Net::FCP
88	#object, a txn object, the type of the transaction and the attributes. Use
89	#it like this:
90	#
91	# sub progress_cb {
92	# my ($self, $txn, $type, $attr) = @_;
93	#
94	# warn "progress<$txn,$type," . (join ":", %$attr) . ">\n";
95	# }
96		98
97	=cut	99	=cut
98		100
99	sub new {	101	sub new {
100	my $class = shift;	102	my $class = shift;
		103
		104	my $rand = join "", map chr 0x21 + rand 94, 1..40; # ~ 262 bits entropy
		105
101	my $self = bless { @_ }, $class;	106	my $self = bless {
102
103	$self->{host} ||= $ENV{FREDHOST} || "127.0.0.1";	107	host => $ENV{FREDHOST} || "127.0.0.1",
104	$self->{port} ||= $ENV{FREDPORT} || 9481;	108	port => $ENV{FREDPORT} || 9481,
105	$self->{name} ||= time.rand.rand.rand; # lame	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;
106		118
		119	{
		120	Scalar::Util::weaken (my $self = $self);
		121
		122	$self->{kw} = AE::timer $self->{keepalive}, $self->{keepalive}, sub {
		123	$self->{hdl}->push_write ("\n");
		124	};
		125
		126	our $ENDMESSAGE = qr<\012(EndMessage|Data)\012>;
		127
		128	# these are declared here for performance reasons
		129	my ($k, $v, $type);
		130	my $rdata;
		131
		132	my $on_read = sub {
		133	my ($hdl) = @_;
		134
		135	# we only carve out whole messages here
		136	while ($hdl->{rbuf} =~ /\012(EndMessage|Data)\012/) {
		137	# remember end marker
		138	$rdata = $1 eq "Data"
		139	or $1 eq "EndMessage"
		140	or die "protocol error, expected message end, got $1\n";
		141
		142	my @lines = split /\012/, substr $hdl->{rbuf}, 0, $-[0];
		143
		144	substr $hdl->{rbuf}, 0, $+[0], ""; # remove pkg
		145
		146	$type = shift @lines;
		147	$type = ($TOLC{$type} ||= tolc $type);
		148
		149	my %kv;
		150
		151	for (@lines) {
		152	($k, $v) = split /=/, $_, 2;
		153	$k = ($TOLC{$k} ||= tolc $k);
		154
		155	if ($k =~ /\./) {
		156	# generic, slow case
		157	my @k = split /\./, $k;
		158	my $ro = \\%kv;
		159
		160	while (@k) {
		161	$k = shift @k;
		162	if ($k =~ /^\d+$/) {
		163	$ro = \$$ro->[$k];
		164	} else {
		165	$ro = \$$ro->{$k};
		166	}
		167	}
		168
		169	$$ro = $v;
		170
		171	next;
		172	}
		173
		174	# special comon case, for performance only
		175	$kv{$k} = $v;
		176	}
		177
		178	if ($rdata) {
		179	$_[0]->push_read (chunk => delete $kv{data_length}, sub {
		180	$rdata = \$_[1];
		181	$self->recv ($type, \%kv, $rdata);
		182	});
		183
		184	last; # do not tgry to parse more messages
		185	} else {
		186	$self->recv ($type, \%kv);
		187	}
		188	}
		189	};
		190
107	$self->{conn} = new AnyEvent::Socket	191	$self->{hdl} = new AnyEvent::Handle
108	PeerAddr => "$self->{host}:$self->{port}",	192	connect => [$self->{host} => $self->{port}],
		193	timeout => $self->{timeout},
		194	on_error => sub {
		195	warn "$self->{host}: $_[2]\n";#d#
		196	exit 1;
		197	},
		198	on_read => $on_read,
109	on_eof => $self->{on_eof} || sub { },	199	on_eof => $self->{on_eof} || sub { },
		200	;
		201
		202	Scalar::Util::weaken ($self->{hdl}{fcp} = $self);
		203	}
		204
		205	$self->send_msg (client_hello =>
		206	name => $self->{name},
		207	expected_version => "2.0",
		208	);
110		209
111	$self	210	$self
112	}	211	}
113		212
114	sub progress {	213	sub identifier {
		214	$_[0]{prefix} . ++$_[0]{idseq}
		215	}
		216
		217	sub send_msg {
115	my ($self, $txn, $type, $attr) = @_;	218	my ($self, $type, %kv) = @_;
116		219
117	$self->{progress}->($self, $txn, $type, $attr)	220	my $data = delete $kv{data};
118	if $self->{progress};
119	}
120		221
121	=item $txn = $fcp->txn (type => attr => val,...)	222	if (exists $kv{id_cb}) {
122		223	my $id = $kv{identifier} ||= $self->identifier;
123	The low-level interface to transactions. Don't use it unless you have	224	$self->{id}{$id} = delete $kv{id_cb};
124	"special needs". Instead, use predefiend transactions like this:
125
126	The blocking case, no (visible) transactions involved:
127
128	my $nodehello = $fcp->client_hello;
129
130	A transaction used in a blocking fashion:
131		225	}
132	my $txn = $fcp->txn_client_hello;
133	...
134	my $nodehello = $txn->result;
135		226
136	Or shorter:	227	my $msg = (touc $type) . "\012"
		228	. join "", map +(touc $_) . "=$kv{$_}\012", keys %kv;
137		229
138	my $nodehello = $fcp->txn_client_hello->result;	230	sub id {
		231	my ($self) = @_;
139		232
140	Setting callbacks:
141		233
142	$fcp->txn_client_hello->cb(	234	}
143	sub { my $nodehello => $_[0]->result }	235
		236	if (defined $data) {
		237	$msg .= "DataLength=" . (length $data) . "\012"
		238	. "Data\012$data";
		239	} else {
		240	$msg .= "EndMessage\012";
		241	}
		242
		243	$self->{hdl}->push_write ($msg);
		244	}
		245
		246	sub on {
		247	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	push @{ $self->{on} }, $cb;
		254	}
		255
		256	sub _push_queue {
		257	my ($self, $queue) = @_;
		258
		259	shift @$queue;
		260	$queue->[0]($self, AnyEvent::Util::guard { $self->_push_queue ($queue) })
		261	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	my ($self, $type, $cb) = @_;
		268
		269	my $queue = $self->{serialise}{$type} ||= [];
		270	push @$queue, $cb;
		271	$cb->($self, AnyEvent::Util::guard { $self->_push_queue ($queue) })
		272	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	my ($self, $type, $kv, @extra) = @_;
		305
		306	if (my $cb = $PERSISTENT_TYPE{$type}) {
		307	my $id = $kv->{identifier};
		308	my $req = $_[0]{req}{$id} ||= {};
		309	$cb->($self, $req, $kv);
		310	$self->recv (request_changed => $kv, $type, @extra);
		311	}
		312
		313	my $on = $self->{on};
		314	for (0 .. $#$on) {
		315	unless (my $res = $on->[$_]($self, $type, $kv, @extra)) {
		316	splice @$on, $_, 1 unless defined $res;
		317	return;
		318	}
		319	}
		320
		321	if (my $cb = $self->{queue}[0]) {
		322	$cb->($self, $type, $kv, @extra)
		323	and shift @{ $self->{queue} };
		324	} else {
		325	$self->default_recv ($type, $kv, @extra);
		326	}
		327	}
		328
		329	sub default_recv {
		330	my ($self, $type, $kv, $rdata) = @_;
		331
		332	if ($type eq "node_hello") {
		333	$self->{node_hello} = $kv;
		334	} elsif (exists $self->{id}{$kv->{identifier}}) {
		335	$self->{id}{$kv->{identifier}}($self, $type, $kv, $rdata)
		336	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<synchronous> - 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<undef>
		394
		395	This is the same thing as specifying C<sub { }> 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	my ($name, $sub) = @_;
		410
		411	*{$name} = sub {
		412	my $cv = AE::cv;
		413
		414	splice @_, 1, 0, $cv, sub { $cv->croak ($_[0]{extra_description}) };
		415	&$sub;
		416	$cv->recv
		417	};
		418
		419	*{"$name\_"} = sub {
		420	my ($ok, $err) = pop;
		421
		422	if (ARRAY:: eq ref $ok) {
		423	($ok, $err) = @$ok;
		424	} elsif (UNIVERSAL::isa $ok, AnyEvent::CondVar::) {
		425	$err = sub { $ok->croak ($_[0]{extra_description}) };
		426	} else {
		427	my $bt = Carp::longmess "";
		428	$err = sub {
		429	die "$_[0]{code_description} ($_[0]{extra_description})$bt";
		430	};
		431	}
		432
		433	$ok ||= $NOP_CB;
		434
		435	splice @_, 1, 0, $ok, $err;
		436	&$sub;
		437	};
		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	},
144	);	465	);
145
146	=cut
147
148	sub txn {
149	my ($self, $type, %attr) = @_;
150
151	$type = touc $type;
152
153	my $txn = "Net::FCP::Txn::$type"->new (fcp => $self, type => tolc $type, attr => \%attr);
154
155	$txn;
156	}
157
158	{ # transactions
159
160	my $txn = sub {
161	my ($name, $sub) = @_;
162	*{"txn_$name"} = $sub;
163	*{$name} = sub { $sub->(@_)->result };
164	};	466	};
165		467
166	=item $txn = $fcp->txn_client_hello	468	=item $notes = $fcp->list_peer_notes ($node_identifier)
167		469
168	=item $nodehello = $fcp->client_hello	470	=cut
169		471
170	Executes a ClientHello request and returns it's results.	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<client_token> or C<priority_class> 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<undef>.
		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<http://wiki.freenetproject.org/FCP2p0ClientGet>).
		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<TestDDARequest> and C<TestDDAResponse> 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<AnyEvent::FCP> 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<AnyEvent::FCP> 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<type> 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<simple_progress> 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<request_changed> 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<watch_global> to subscribe to updates, followed by
		837	C<list_persistent_requests_sync>.
		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"} >>:
171		844
172	{	845	{
173	max_file_size => "5f5e100",	846	identifier => "Frost-gpl.txt",
174	node => "Fred,0.6,1.46,7050"	847	uri => 'CHK@Fnx5kzdrfE,EImdzaVyEWl,AAIC--8/gpl.txt',
175	protocol => "1.2",	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	},
176	}	912	}
177		913
178	=cut	914	=head1 EXAMPLE PROGRAM
179		915
180	$txn->(client_hello => sub {	916	use AnyEvent::FCP;
181	my ($self) = @_;
182		917
183	$self->txn ("client_hello");	918	my $fcp = new AnyEvent::FCP;
184	});
185		919
186	=item $txn = $fcp->txn_client_info	920	# let us look at the global request list
		921	$fcp->watch_global_ (1);
187		922
188	=item $nodeinfo = $fcp->client_info	923	# list them, synchronously
		924	my $req = $fcp->list_persistent_requests;
189		925
190	Executes a ClientInfo request and returns it's results.	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:/;
191		933
192	{	934	if ($req->{data_found}) {
193	active_jobs => "1f",	935	# file has been successfully downloaded
194	allocated_memory => "bde0000",	936
195	architecture => "i386",	937	... move the file away
196	available_threads => 17,	938	(left as exercise)
197	datastore_free => "5ce03400",	939
198	datastore_max => "2540be400",	940	# remove the request
199	datastore_used => "1f72bb000",	941
200	estimated_load => 52,	942	$fcp->remove_request (1, $req->{identifier});
201	free_memory => "5cc0148",	943	} elsif ($req->{get_failed}) {
202	is_transient => "false",	944	# request has failed
203	java_name => "Java HotSpot(_T_M) Server VM",	945	if ($req->{get_failed}{code} == 11) {
204	java_vendor => "http://www.blackdown.org/",	946	# too many path components, should restart
205	java_version => "Blackdown-1.4.1-01",	947	} else {
206	least_recent_timestamp => "f41538b878",	948	# other failure
207	max_file_size => "5f5e100",	949	}
208	most_recent_timestamp => "f77e2cc520"	950	} else {
209	node_address => "1.2.3.4",	951	# modify priorities randomly, to improve download rates
210	node_port => 369,	952	$fcp->modify_persistent_request (1, $req->{identifier}, undef, int 6 - 5 * (rand) ** 1.7)
211	operating_system => "Linux",	953	if 0.1 > rand;
212	operating_system_version => "2.4.20",	954	}
213	routing_time => "a5",
214	}	955	}
215		956
216	=cut	957	# see if the dummy plugin is loaded, to ensure all previous requests have finished.
217		958	$fcp->get_plugin_info_sync ("dummy");
218	$txn->(client_info => sub {
219	my ($self) = @_;
220
221	$self->txn ("client_info");
222	});
223
224	=item $txn = $fcp->txn_generate_chk ($metadata, $data[, $cipher])
225
226	=item $uri = $fcp->generate_chk ($metadata, $data[, $cipher])
227
228	Calculates a CHK, given the metadata and data. C<$cipher> is either
229	C<Rijndael> or C<Twofish>, with the latter being the default.
230
231	=cut
232
233	$txn->(generate_chk => sub {
234	my ($self, $metadata, $data, $cipher) = @_;
235
236	$metadata = Net::FCP::Metadata::build_metadata $metadata;
237
238	$self->txn (generate_chk =>
239	data => "$metadata$data",
240	metadata_length => xeh length $metadata,
241	cipher => $cipher || "Twofish");
242	});
243
244	=item $txn = $fcp->txn_generate_svk_pair
245
246	=item ($public, $private, $crypto) = @{ $fcp->generate_svk_pair }
247
248	Creates a new SVK pair. Returns an arrayref with the public key, the
249	private key and a crypto key, which is just additional entropy.
250
251	[
252	"acLx4dux9fvvABH15Gk6~d3I-yw",
253	"cPoDkDMXDGSMM32plaPZDhJDxSs",
254	"BH7LXCov0w51-y9i~BoB3g",
255	]
256
257	A private key (for inserting) can be constructed like this:
258
259	SSK@<private_key>,<crypto_key>/<name>
260
261	It can be used to insert data. The corresponding public key looks like this:
262
263	SSK@<public_key>PAgM,<crypto_key>/<name>
264
265	Watch out for the C<PAgM>-part!
266
267	=cut
268
269	$txn->(generate_svk_pair => sub {
270	my ($self) = @_;
271
272	$self->txn ("generate_svk_pair");
273	});
274
275	=item $txn = $fcp->txn_invert_private_key ($private)
276
277	=item $public = $fcp->invert_private_key ($private)
278
279	Inverts a private key (returns the public key). C<$private> can be either
280	an insert URI (must start with C<freenet:SSK@>) or a raw private key (i.e.
281	the private value you get back from C<generate_svk_pair>).
282
283	Returns the public key.
284
285	=cut
286
287	$txn->(invert_private_key => sub {
288	my ($self, $privkey) = @_;
289
290	$self->txn (invert_private_key => private => $privkey);
291	});
292
293	=item $txn = $fcp->txn_get_size ($uri)
294
295	=item $length = $fcp->get_size ($uri)
296
297	Finds and returns the size (rounded up to the nearest power of two) of the
298	given document.
299
300	=cut
301
302	$txn->(get_size => sub {
303	my ($self, $uri) = @_;
304
305	$self->txn (get_size => URI => $uri);
306	});
307
308	=item $txn = $fcp->txn_client_get ($uri [, $htl = 15 [, $removelocal = 0]])
309
310	=item ($metadata, $data) = @{ $fcp->client_get ($uri, $htl, $removelocal)
311
312	Fetches a (small, as it should fit into memory) key content block from
313	freenet. C<$meta> is a C<Net::FCP::Metadata> object or C<undef>).
314
315	The C<$uri> should begin with C<freenet:>, but the scheme is currently
316	added, if missing.
317
318	my ($meta, $data) = @{
319	$fcp->client_get (
320	"freenet:CHK@hdXaxkwZ9rA8-SidT0AN-bniQlgPAwI,XdCDmBuGsd-ulqbLnZ8v~w"
321	)
322	};
323
324	=cut
325
326	$txn->(client_get => sub {
327	my ($self, $uri, $htl, $removelocal) = @_;
328
329	$uri =~ s/^freenet://; $uri = "freenet:$uri";
330
331	$self->txn (client_get => URI => $uri, hops_to_live => xeh (defined $htl ? $htl : 15),
332	remove_local_key => $removelocal ? "true" : "false");
333	});
334
335	=item $txn = $fcp->txn_client_put ($uri, $metadata, $data, $htl, $removelocal)
336
337	=item my $uri = $fcp->client_put ($uri, $metadata, $data, $htl, $removelocal);
338
339	Insert a new key. If the client is inserting a CHK, the URI may be
340	abbreviated as just CHK@. In this case, the node will calculate the
341	CHK. If the key is a private SSK key, the node will calculcate the public
342	key and the resulting public URI.
343
344	C<$meta> can be a hash reference (same format as returned by
345	C<Net::FCP::parse_metadata>) or a string.
346
347	The result is an arrayref with the keys C<uri>, C<public_key> and C<private_key>.
348
349	=cut
350
351	$txn->(client_put => sub {
352	my ($self, $uri, $metadata, $data, $htl, $removelocal) = @_;
353
354	$metadata = Net::FCP::Metadata::build_metadata $metadata;
355	$uri =~ s/^freenet://; $uri = "freenet:$uri";
356
357	$self->txn (client_put => URI => $uri,
358	hops_to_live => xeh (defined $htl ? $htl : 15),
359	remove_local_key => $removelocal ? "true" : "false",
360	data => "$metadata$data", metadata_length => xeh length $metadata);
361	});
362
363	} # transactions
364
365	=back
366
367	=head2 THE Net::FCP::Txn CLASS
368
369	All requests (or transactions) are executed in a asynchronous way. For
370	each request, a C<Net::FCP::Txn> object is created (worse: a tcp
371	connection is created, too).
372
373	For each request there is actually a different subclass (and it's possible
374	to subclass these, although of course not documented).
375
376	The most interesting method is C<result>.
377
378	=over 4
379
380	=cut
381
382	package Net::FCP::Txn;
383
384	use Fcntl;
385	use Socket;
386
387	=item new arg => val,...
388
389	Creates a new C<Net::FCP::Txn> object. Not normally used.
390
391	=cut
392
393	sub new {
394	my $class = shift;
395	my $self = bless { @_ }, $class;
396
397	$self->{signal} = AnyEvent->condvar;
398
399	$self->{fcp}{txn}{$self} = $self;
400
401	my $attr = "";
402	my $data = delete $self->{attr}{data};
403
404	while (my ($k, $v) = each %{$self->{attr}}) {
405	$attr .= (Net::FCP::touc $k) . "=$v\012"
406	}
407
408	if (defined $data) {
409	$attr .= sprintf "DataLength=%x\012", length $data;
410	$data = "Data\012$data";
411	} else {
412	$data = "EndMessage\012";
413	}
414
415	socket my $fh, PF_INET, SOCK_STREAM, 0
416	or Carp::croak "unable to create new tcp socket: $!";
417	binmode $fh, ":raw";
418	fcntl $fh, F_SETFL, O_NONBLOCK;
419	connect $fh, (sockaddr_in $self->{fcp}{port}, inet_aton $self->{fcp}{host});
420	# and Carp::croak "FCP::txn: unable to connect to $self->{fcp}{host}:$self->{fcp}{port}: $!\n";
421
422	$self->{sbuf} =
423	"\x00\x00\x00\x02"
424	. (Net::FCP::touc $self->{type})
425	. "\012$attr$data";
426
427	#shutdown $fh, 1; # freenet buggy?, well, it's java...
428
429	$self->{fh} = $fh;
430
431	$self->{w} = AnyEvent->io (fh => $fh, poll => 'w', cb => sub { $self->fh_ready_w });
432
433	$self;
434	}
435
436	=item $txn = $txn->cb ($coderef)
437
438	Sets a callback to be called when the request is finished. The coderef
439	will be called with the txn as it's sole argument, so it has to call
440	C<result> itself.
441
442	Returns the txn object, useful for chaining.
443
444	Example:
445
446	$fcp->txn_client_get ("freenet:CHK....")
447	->userdata ("ehrm")
448	->cb(sub {
449	my $data = shift->result;
450	});
451
452	=cut
453
454	sub cb($$) {
455	my ($self, $cb) = @_;
456	$self->{cb} = $cb;
457	$self;
458	}
459
460	=item $txn = $txn->userdata ([$userdata])
461
462	Set user-specific data. This is useful in progress callbacks. The data can be accessed
463	using C<< $txn->{userdata} >>.
464
465	Returns the txn object, useful for chaining.
466
467	=cut
468
469	sub userdata($$) {
470	my ($self, $data) = @_;
471	$self->{userdata} = $data;
472	$self;
473	}
474
475	=item $txn->cancel (%attr)
476
477	Cancels the operation with a C<cancel> exception and the given attributes
478	(consider at least giving the attribute C<reason>).
479
480	UNTESTED.
481
482	=cut
483
484	sub cancel {
485	my ($self, %attr) = @_;
486	$self->throw (Net::FCP::Exception->new (cancel => { %attr }));
487	$self->set_result;
488	$self->eof;
489	}
490
491	sub fh_ready_w {
492	my ($self) = @_;
493
494	my $len = syswrite $self->{fh}, $self->{sbuf};
495
496	if ($len > 0) {
497	substr $self->{sbuf}, 0, $len, "";
498	unless (length $self->{sbuf}) {
499	fcntl $self->{fh}, F_SETFL, 0;
500	$self->{w} = AnyEvent->io (fh => $self->{fh}, poll => 'r', cb => sub { $self->fh_ready_r });
501	}
502	} elsif (defined $len) {
503	$self->throw (Net::FCP::Exception->new (network_error => { reason => "unexpected end of file while writing" }));
504	} else {
505	$self->throw (Net::FCP::Exception->new (network_error => { reason => "$!" }));
506	}
507	}
508
509	sub fh_ready_r {
510	my ($self) = @_;
511
512	if (sysread $self->{fh}, $self->{buf}, 16384 + 1024, length $self->{buf}) {
513	for (;;) {
514	if ($self->{datalen}) {
515	#warn "expecting new datachunk $self->{datalen}, got ".(length $self->{buf})."\n";#d#
516	if (length $self->{buf} >= $self->{datalen}) {
517	$self->rcv_data (substr $self->{buf}, 0, delete $self->{datalen}, "");
518	} else {
519	last;
520	}
521	} elsif ($self->{buf} =~ s/^DataChunk\015?\012Length=([0-9a-fA-F]+)\015?\012Data\015?\012//) {
522	$self->{datalen} = hex $1;
523	#warn "expecting new datachunk $self->{datalen}\n";#d#
524	} elsif ($self->{buf} =~ s/^([a-zA-Z]+)\015?\012(?:(.+?)\015?\012)?EndMessage\015?\012//s) {
525	$self->rcv ($1, {
526	map { my ($a, $b) = split /=/, $_, 2; ((Net::FCP::tolc $a), $b) }
527	split /\015?\012/, $2
528	});
529	} else {
530	last;
531	}
532	}
533	} else {
534	$self->eof;
535	}
536	}
537
538	sub rcv {
539	my ($self, $type, $attr) = @_;
540
541	$type = Net::FCP::tolc $type;
542
543	#use PApp::Util; warn PApp::Util::dumpval [$type, $attr];
544
545	if (my $method = $self->can("rcv_$type")) {
546	$method->($self, $attr, $type);
547	} else {
548	warn "received unexpected reply type '$type' for '$self->{type}', ignoring\n";
549	}
550	}
551
552	# used as a default exception thrower
553	sub rcv_throw_exception {
554	my ($self, $attr, $type) = @_;
555	$self->throw (Net::FCP::Exception->new ($type, $attr));
556	}
557
558	*rcv_failed = \&Net::FCP::Txn::rcv_throw_exception;
559	*rcv_format_error = \&Net::FCP::Txn::rcv_throw_exception;
560
561	sub throw {
562	my ($self, $exc) = @_;
563
564	$self->{exception} = $exc;
565	$self->set_result;
566	$self->eof; # must be last to avoid loops
567	}
568
569	sub set_result {
570	my ($self, $result) = @_;
571
572	unless (exists $self->{result}) {
573	$self->{result} = $result;
574	$self->{cb}->($self) if exists $self->{cb};
575	$self->{signal}->broadcast;
576	}
577	}
578
579	sub eof {
580	my ($self) = @_;
581
582	delete $self->{w};
583	delete $self->{fh};
584
585	delete $self->{fcp}{txn}{$self};
586
587	unless (exists $self->{result}) {
588	$self->throw (Net::FCP::Exception->new (short_data => {
589	reason => "unexpected eof or internal node error",
590	}));
591	}
592	}
593
594	sub progress {
595	my ($self, $type, $attr) = @_;
596
597	$self->{fcp}->progress ($self, $type, $attr);
598	}
599
600	=item $result = $txn->result
601
602	Waits until a result is available and then returns it.
603
604	This waiting is (depending on your event model) not very efficient, as it
605	is done outside the "mainloop". The biggest problem, however, is that it's
606	blocking one thread of execution. Try to use the callback mechanism, if
607	possible, and call result from within the callback (or after is has been
608	run), as then no waiting is necessary.
609
610	=cut
611
612	sub result {
613	my ($self) = @_;
614
615	$self->{signal}->wait while !exists $self->{result};
616
617	die $self->{exception} if $self->{exception};
618
619	return $self->{result};
620	}
621
622	package Net::FCP::Txn::ClientHello;
623
624	use base Net::FCP::Txn;
625
626	sub rcv_node_hello {
627	my ($self, $attr) = @_;
628
629	$self->set_result ($attr);
630	}
631
632	package Net::FCP::Txn::ClientInfo;
633
634	use base Net::FCP::Txn;
635
636	sub rcv_node_info {
637	my ($self, $attr) = @_;
638
639	$self->set_result ($attr);
640	}
641
642	package Net::FCP::Txn::GenerateCHK;
643
644	use base Net::FCP::Txn;
645
646	sub rcv_success {
647	my ($self, $attr) = @_;
648
649	$self->set_result ($attr->{uri});
650	}
651
652	package Net::FCP::Txn::GenerateSVKPair;
653
654	use base Net::FCP::Txn;
655
656	sub rcv_success {
657	my ($self, $attr) = @_;
658	$self->set_result ([$attr->{public_key}, $attr->{private_key}, $attr->{crypto_key}]);
659	}
660
661	package Net::FCP::Txn::InvertPrivateKey;
662
663	use base Net::FCP::Txn;
664
665	sub rcv_success {
666	my ($self, $attr) = @_;
667	$self->set_result ($attr->{public_key});
668	}
669
670	package Net::FCP::Txn::GetSize;
671
672	use base Net::FCP::Txn;
673
674	sub rcv_success {
675	my ($self, $attr) = @_;
676	$self->set_result (hex $attr->{length});
677	}
678
679	package Net::FCP::Txn::GetPut;
680
681	# base class for get and put
682
683	use base Net::FCP::Txn;
684
685	*rcv_uri_error = \&Net::FCP::Txn::rcv_throw_exception;
686	*rcv_route_not_found = \&Net::FCP::Txn::rcv_throw_exception;
687
688	sub rcv_restarted {
689	my ($self, $attr, $type) = @_;
690
691	delete $self->{datalength};
692	delete $self->{metalength};
693	delete $self->{data};
694
695	$self->progress ($type, $attr);
696	}
697
698	package Net::FCP::Txn::ClientGet;
699
700	use base Net::FCP::Txn::GetPut;
701
702	*rcv_data_not_found = \&Net::FCP::Txn::rcv_throw_exception;
703
704	sub rcv_data {
705	my ($self, $chunk) = @_;
706
707	$self->{data} .= $chunk;
708
709	$self->progress ("data", { chunk => length $chunk, received => length $self->{data}, total => $self->{datalength} });
710
711	if ($self->{datalength} == length $self->{data}) {
712	my $data = delete $self->{data};
713	my $meta = new Net::FCP::Metadata (substr $data, 0, $self->{metalength}, "");
714
715	$self->set_result ([$meta, $data]);
716	$self->eof;
717	}
718	}
719
720	sub rcv_data_found {
721	my ($self, $attr, $type) = @_;
722
723	$self->progress ($type, $attr);
724
725	$self->{datalength} = hex $attr->{data_length};
726	$self->{metalength} = hex $attr->{metadata_length};
727	}
728
729	package Net::FCP::Txn::ClientPut;
730
731	use base Net::FCP::Txn::GetPut;
732
733	*rcv_size_error = \&Net::FCP::Txn::rcv_throw_exception;
734
735	sub rcv_pending {
736	my ($self, $attr, $type) = @_;
737	$self->progress ($type, $attr);
738	}
739
740	sub rcv_success {
741	my ($self, $attr, $type) = @_;
742	$self->set_result ($attr);
743	}
744
745	sub rcv_key_collision {
746	my ($self, $attr, $type) = @_;
747	$self->set_result ({ key_collision => 1, %$attr });
748	}
749
750	=back
751
752	=head2 The Net::FCP::Exception CLASS
753
754	Any unexpected (non-standard) responses that make it impossible to return
755	the advertised result will result in an exception being thrown when the
756	C<result> method is called.
757
758	These exceptions are represented by objects of this class.
759
760	=over 4
761
762	=cut
763
764	package Net::FCP::Exception;
765
766	use overload
767	'""' => sub {
768	"Net::FCP::Exception<<$_[0][0]," . (join ":", %{$_[0][1]}) . ">>";
769	};
770
771	=item $exc = new Net::FCP::Exception $type, \%attr
772
773	Create a new exception object of the given type (a string like
774	C<route_not_found>), and a hashref containing additional attributes
775	(usually the attributes of the message causing the exception).
776
777	=cut
778
779	sub new {
780	my ($class, $type, $attr) = @_;
781
782	bless [Net::FCP::tolc $type, { %$attr }], $class;
783	}
784
785	=item $exc->type([$type])
786
787	With no arguments, returns the exception type. Otherwise a boolean
788	indicating wether the exception is of the given type is returned.
789
790	=cut
791
792	sub type {
793	my ($self, $type) = @_;
794
795	@_ >= 2
796	? $self->[0] eq $type
797	: $self->[0];
798	}
799
800	=item $exc->attr([$attr])
801
802	With no arguments, returns the attributes. Otherwise the named attribute
803	value is returned.
804
805	=cut
806
807	sub attr {
808	my ($self, $attr) = @_;
809
810	@_ >= 2
811	? $self->[1]{$attr}
812	: $self->[1];
813	}
814
815	=back
816		959
817	=head1 SEE ALSO	960	=head1 SEE ALSO
818		961
819	L<http://freenet.sf.net>.	962	L<http://wiki.freenetproject.org/FreenetFCPSpec2Point0>, L<Net::FCP>.
820		963
821	=head1 BUGS	964	=head1 BUGS
822		965
823	=head1 AUTHOR	966	=head1 AUTHOR
824		967

Diff Legend

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