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

Diff Legend

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