[ViewVC] Diff of: cvs/Net-FCP/FCP.pm

Comparing Net-FCP/FCP.pm (file contents):
Revision 1.8 by root, Mon Sep 8 01:47:31 2003 UTC vs.
Revision 1.41 by root, Thu May 1 15:30:15 2008 UTC

…		…
11	my $ni = $fcp->txn_node_info->result;	11	my $ni = $fcp->txn_node_info->result;
12	my $ni = $fcp->node_info;	12	my $ni = $fcp->node_info;
13		13
14	=head1 DESCRIPTION	14	=head1 DESCRIPTION
15		15
		16	This module implements the first version of the freenet client protocol,
		17	for use with freenet versions 0.5. For freenet protocol version 2.0
		18	support (as used by freenet 0.7), see the L<AnyEvent::FCP> module.
		19
16	See L<http://freenet.sourceforge.net/index.php?page=fcp> for a description	20	See L<http://freenet.sourceforge.net/index.php?page=fcp> for a description
17	of what the messages do. I am too lazy to document all this here.	21	of what the messages do.
18		22
19	=head1 WARNING	23	The module uses L<AnyEvent> to find a suitable Event module.
20		24
21	This module is alpha. While it probably won't destroy (much :) of your	25	=head2 IMPORT TAGS
22	data, it currently works only with the Event module (alkthough the event	26
23	mechanism is fully pluggable).	27	Nothing much can be "imported" from this module right now.
		28
		29	=head2 FREENET BASICS
		30
		31	Ok, this section will not explain any freenet basics to you, just some
		32	problems I found that you might want to avoid:
		33
		34	=over 4
		35
		36	=item freenet URIs are _NOT_ URIs
		37
		38	Whenever a "uri" is required by the protocol, freenet expects a kind of
		39	URI prefixed with the "freenet:" scheme, e.g. "freenet:CHK...". However,
		40	these are not URIs, as freeent fails to parse them correctly, that is, you
		41	must unescape an escaped characters ("%2c" => ",") yourself. Maybe in the
		42	future this library will do it for you, so watch out for this incompatible
		43	change.
		44
		45	=item Numbers are in HEX
		46
		47	Virtually every number in the FCP protocol is in hex. Be sure to use
		48	C<hex()> on all such numbers, as the module (currently) does nothing to
		49	convert these for you.
		50
		51	=back
24		52
25	=head2 THE Net::FCP CLASS	53	=head2 THE Net::FCP CLASS
26		54
27	=over 4	55	=over 4
28		56
29	=cut	57	=cut
30		58
31	package Net::FCP;	59	package Net::FCP;
32		60
33	use Carp;	61	use Carp;
34	use IO::Socket::INET;
35		62
36	$VERSION = 0.04;	63	$VERSION = '1.2';
37		64
38	sub event_reg_cb {	65	no warnings;
39	my ($obj) = @_;
40	require Event;
41		66
42	$obj->{eventdata} = Event->io (	67	use AnyEvent;
43	fd => $obj->{fh},
44	poll => 'r',
45	cb => sub {
46	$obj->fh_ready;
47	},
48	);
49	}
50		68
51	sub event_unreg_cb {	69	use Net::FCP::Metadata;
52	$_[0]{eventdata}	70	use Net::FCP::Util qw(tolc touc xeh);
53	and (delete $_[0]{eventdata})->cancel;
54	}
55		71
56	sub event_wait_cb {
57	Event::one_event();
58	}
59
60	$regcb = \&event_reg_cb;
61	$unregcb = \&event_unreg_cb;
62	$waitcb = \&event_wait_cb;
63
64	sub touc($) {
65	local $_ = shift;
66	1 while s/((?:^\|_)(?:svk\|chk\|uri)(?:_\|$))/\U$1/;
67	s/(?:^\|_)(.)/\U$1/g;
68	$_;
69	}
70
71	sub tolc($) {
72	local $_ = shift;
73	s/(?<=[a-z])(?=[A-Z])/_/g;
74	lc $_;
75	}
76
77	=item $meta = Net::FCP::parse_metadata $string
78
79	Parse a metadata string and return it.
80
81	The metadata will be a hashref with key C<version> (containing
82	the mandatory version header entries).
83
84	All other headers are represented by arrayrefs (they can be repeated).
85
86	Since this is confusing, here is a rather verbose example of a parsed
87	manifest:
88
89	(
90	version => { revision => 1 },
91	document => [
92	{
93	"info.format" => "image/jpeg",
94	name => "background.jpg",
95	"redirect.target" => "freenet:CHK\@ZcagI,ra726bSw"
96	},
97	{
98	"info.format" => "text/html",
99	name => ".next",
100	"redirect.target" => "freenet:SSK\@ilUPAgM/TFEE/3"
101	},
102	{
103	"info.format" => "text/html",
104	"redirect.target" => "freenet:CHK\@8M8Po8ucwI,8xA"
105	}
106	]
107	)
108
109	=cut
110
111	sub parse_metadata {
112	my $meta;
113
114	my $data = shift;
115	if ($data =~ /^Version\015?\012/gc) {
116	my $hdr = $meta->{version} = {};
117
118	for (;;) {
119	while ($data =~ /\G([^=\015\012]+)=([^\015\012]*)\015?\012/gc) {
120	my ($k, $v) = ($1, $2);
121	$hdr->{tolc $k} = $v;
122	}
123
124	if ($data =~ /\GEndPart\015?\012/gc) {
125	} elsif ($data =~ /\GEnd\015?\012/gc) {
126	last;
127	} elsif ($data =~ /\G([A-Za-z0-9.\-]+)\015?\012/gcs) {
128	push @{$meta->{tolc $1}}, $hdr = {};
129	} elsif ($data =~ /\G(.*)/gcs) {
130	die "metadata format error ($1)";
131	}
132	}
133	}
134
135	#$meta->{tail} = substr $data, pos $data;
136
137	$meta;
138	}
139
140	=item $fcp = new Net::FCP [host => $host][, port => $port]	72	=item $fcp = new Net::FCP [host => $host][, port => $port][, progress => \&cb]
141		73
142	Create a new virtual FCP connection to the given host and port (default	74	Create a new virtual FCP connection to the given host and port (default
143	127.0.0.1:8481, or the environment variables C<FREDHOST> and C<FREDPORT>).	75	127.0.0.1:8481, or the environment variables C<FREDHOST> and C<FREDPORT>).
144		76
145	Connections are virtual because no persistent physical connection is	77	Connections are virtual because no persistent physical connection is
146	established. However, the existance of the node is checked by executing a	78	established.
147	C<ClientHello> transaction.	79
		80	You can install a progress callback that is being called with the Net::FCP
		81	object, a txn object, the type of the transaction and the attributes. Use
		82	it like this:
		83
		84	sub progress_cb {
		85	my ($self, $txn, $type, $attr) = @_;
		86
		87	warn "progress<$txn,$type," . (join ":", %$attr) . ">\n";
		88	}
148		89
149	=cut	90	=cut
150		91
151	sub new {	92	sub new {
152	my $class = shift;	93	my $class = shift;
153	my $self = bless { @_ }, $class;	94	my $self = bless { @_ }, $class;
154		95
155	$self->{host} \|\|= $ENV{FREDHOST} \|\| "127.0.0.1";	96	$self->{host} \|\|= $ENV{FREDHOST} \|\| "127.0.0.1";
156	$self->{port} \|\|= $ENV{FREDPORt} \|\| 8481;	97	$self->{port} \|\|= $ENV{FREDPORT} \|\| 8481;
157
158	$self->{nodehello} = $self->client_hello
159	or croak "unable to get nodehello from node\n";
160		98
161	$self;	99	$self;
162	}	100	}
163		101
		102	sub progress {
		103	my ($self, $txn, $type, $attr) = @_;
		104
		105	$self->{progress}->($self, $txn, $type, $attr)
		106	if $self->{progress};
		107	}
		108
164	=item $txn = $fcp->txn(type => attr => val,...)	109	=item $txn = $fcp->txn (type => attr => val,...)
165		110
166	The low-level interface to transactions. Don't use it.	111	The low-level interface to transactions. Don't use it unless you have
		112	"special needs". Instead, use predefiend transactions like this:
		113
		114	The blocking case, no (visible) transactions involved:
		115
		116	my $nodehello = $fcp->client_hello;
		117
		118	A transaction used in a blocking fashion:
		119
		120	my $txn = $fcp->txn_client_hello;
		121	...
		122	my $nodehello = $txn->result;
		123
		124	Or shorter:
		125
		126	my $nodehello = $fcp->txn_client_hello->result;
		127
		128	Setting callbacks:
		129
		130	$fcp->txn_client_hello->cb(
		131	sub { my $nodehello => $_[0]->result }
		132	);
167		133
168	=cut	134	=cut
169		135
170	sub txn {	136	sub txn {
171	my ($self, $type, %attr) = @_;	137	my ($self, $type, %attr) = @_;
172		138
173	$type = touc $type;	139	$type = touc $type;
174		140
175	my $txn = "Net::FCP::Txn::$type"->new(fcp => $self, type => tolc $type, attr => \%attr);	141	my $txn = "Net::FCP::Txn::$type"->new (fcp => $self, type => tolc $type, attr => \%attr);
176		142
177	$txn;	143	$txn;
178	}	144	}
179		145
180	sub _txn($&) {	146	{ # transactions
		147
		148	my $txn = sub {
181	my ($name, $sub) = @_;	149	my ($name, $sub) = @_;
182	*{"$name\_txn"} = $sub;	150	*{"txn_$name"} = $sub;
183	*{$name} = sub { $sub->(@_)->result };	151	*{$name} = sub { $sub->(@_)->result };
184	}	152	};
185		153
186	=item $txn = $fcp->txn_client_hello	154	=item $txn = $fcp->txn_client_hello
187		155
188	=item $nodehello = $fcp->client_hello	156	=item $nodehello = $fcp->client_hello
189		157
…		…
195	protocol => "1.2",	163	protocol => "1.2",
196	}	164	}
197		165
198	=cut	166	=cut
199		167
200	_txn client_hello => sub {	168	$txn->(client_hello => sub {
201	my ($self) = @_;	169	my ($self) = @_;
202		170
203	$self->txn ("client_hello");	171	$self->txn ("client_hello");
204	};	172	});
205		173
206	=item $txn = $fcp->txn_client_info	174	=item $txn = $fcp->txn_client_info
207		175
208	=item $nodeinfo = $fcp->client_info	176	=item $nodeinfo = $fcp->client_info
209		177
…		…
233	routing_time => "a5",	201	routing_time => "a5",
234	}	202	}
235		203
236	=cut	204	=cut
237		205
238	_txn client_info => sub {	206	$txn->(client_info => sub {
239	my ($self) = @_;	207	my ($self) = @_;
240		208
241	$self->txn ("client_info");	209	$self->txn ("client_info");
242	};	210	});
243		211
244	=item $txn = $fcp->txn_generate_chk ($metadata, $data)	212	=item $txn = $fcp->txn_generate_chk ($metadata, $data[, $cipher])
245		213
246	=item $uri = $fcp->generate_chk ($metadata, $data)	214	=item $uri = $fcp->generate_chk ($metadata, $data[, $cipher])
247		215
248	Creates a new CHK, given the metadata and data. UNTESTED.	216	Calculates a CHK, given the metadata and data. C<$cipher> is either
		217	C<Rijndael> or C<Twofish>, with the latter being the default.
249		218
250	=cut	219	=cut
251		220
252	_txn generate_chk => sub {	221	$txn->(generate_chk => sub {
253	my ($self, $metadata, $data) = @_;	222	my ($self, $metadata, $data, $cipher) = @_;
254		223
255	$self->txn (generate_chk => data => "$data$metadata", metadata_length => length $metadata);	224	$metadata = Net::FCP::Metadata::build_metadata $metadata;
		225
		226	$self->txn (generate_chk =>
		227	data => "$metadata$data",
		228	metadata_length => xeh length $metadata,
		229	cipher => $cipher \|\| "Twofish");
256	};	230	});
257		231
258	=item $txn = $fcp->txn_generate_svk_pair	232	=item $txn = $fcp->txn_generate_svk_pair
259		233
260	=item ($public, $private) = @{ $fcp->generate_svk_pair }	234	=item ($public, $private, $crypto) = @{ $fcp->generate_svk_pair }
261		235
262	Creates a new SVK pair. Returns an arrayref.	236	Creates a new SVK pair. Returns an arrayref with the public key, the
		237	private key and a crypto key, which is just additional entropy.
263		238
264	[	239	[
265	"hKs0-WDQA4pVZyMPKNFsK1zapWY",	240	"acLx4dux9fvvABH15Gk6~d3I-yw",
266	"ZnmvMITaTXBMFGl4~jrjuyWxOWg"	241	"cPoDkDMXDGSMM32plaPZDhJDxSs",
		242	"BH7LXCov0w51-y9i~BoB3g",
267	]	243	]
268		244
269	=cut	245	A private key (for inserting) can be constructed like this:
270		246
		247	SSK@<private_key>,<crypto_key>/<name>
		248
		249	It can be used to insert data. The corresponding public key looks like this:
		250
		251	SSK@<public_key>PAgM,<crypto_key>/<name>
		252
		253	Watch out for the C<PAgM>-part!
		254
		255	=cut
		256
271	_txn generate_svk_pair => sub {	257	$txn->(generate_svk_pair => sub {
272	my ($self) = @_;	258	my ($self) = @_;
273		259
274	$self->txn ("generate_svk_pair");	260	$self->txn ("generate_svk_pair");
275	};	261	});
276		262
277	=item $txn = $fcp->txn_insert_private_key ($private)	263	=item $txn = $fcp->txn_invert_private_key ($private)
278		264
279	=item $uri = $fcp->insert_private_key ($private)	265	=item $public = $fcp->invert_private_key ($private)
280		266
281	Inserts a private key. $private can be either an insert URI (must start	267	Inverts a private key (returns the public key). C<$private> can be either
282	with freenet:SSK@) or a raw private key (i.e. the private value you get back	268	an insert URI (must start with C<freenet:SSK@>) or a raw private key (i.e.
283	from C<generate_svk_pair>).	269	the private value you get back from C<generate_svk_pair>).
284		270
285	Returns the public key.	271	Returns the public key.
286		272
287	UNTESTED.
288
289	=cut	273	=cut
290		274
291	_txn insert_private_key => sub {	275	$txn->(invert_private_key => sub {
292	my ($self, $privkey) = @_;	276	my ($self, $privkey) = @_;
293		277
294	$self->txn (invert_private_key => private => $privkey);	278	$self->txn (invert_private_key => private => $privkey);
295	};	279	});
296		280
297	=item $txn = $fcp->txn_get_size ($uri)	281	=item $txn = $fcp->txn_get_size ($uri)
298		282
299	=item $length = $fcp->get_size ($uri)	283	=item $length = $fcp->get_size ($uri)
300		284
301	Finds and returns the size (rounded up to the nearest power of two) of the	285	Finds and returns the size (rounded up to the nearest power of two) of the
302	given document.	286	given document.
303		287
304	UNTESTED.
305
306	=cut	288	=cut
307		289
308	_txn get_size => sub {	290	$txn->(get_size => sub {
309	my ($self, $uri) = @_;	291	my ($self, $uri) = @_;
310		292
311	$self->txn (get_size => URI => $uri);	293	$self->txn (get_size => URI => $uri);
312	};	294	});
313		295
314	=item $txn = $fcp->txn_client_get ($uri [, $htl = 15 [, $removelocal = 0]])	296	=item $txn = $fcp->txn_client_get ($uri [, $htl = 15 [, $removelocal = 0]])
315		297
316	=item ($metadata, $data) = @{ $fcp->client_get ($uri, $htl, $removelocal)	298	=item ($metadata, $data) = @{ $fcp->client_get ($uri, $htl, $removelocal)
317		299
318	Fetches a (small, as it should fit into memory) file from	300	Fetches a (small, as it should fit into memory) key content block from
319	freenet. C<$meta> is the metadata (as returned by C<parse_metadata> or	301	freenet. C<$meta> is a C<Net::FCP::Metadata> object or C<undef>).
320	C<undef>).
321		302
322	Due to the overhead, a better method to download big files should be used.	303	The C<$uri> should begin with C<freenet:>, but the scheme is currently
		304	added, if missing.
323		305
324	my ($meta, $data) = @{	306	my ($meta, $data) = @{
325	$fcp->client_get (	307	$fcp->client_get (
326	"freenet:CHK@hdXaxkwZ9rA8-SidT0AN-bniQlgPAwI,XdCDmBuGsd-ulqbLnZ8v~w"	308	"freenet:CHK@hdXaxkwZ9rA8-SidT0AN-bniQlgPAwI,XdCDmBuGsd-ulqbLnZ8v~w"
327	)	309	)
328	};	310	};
329		311
330	=cut	312	=cut
331		313
332	_txn client_get => sub {	314	$txn->(client_get => sub {
333	my ($self, $uri, $htl, $removelocal) = @_;	315	my ($self, $uri, $htl, $removelocal) = @_;
334		316
335	$self->txn (client_get => URI => $uri, hops_to_live => ($htl \|\| 15), remove_local => $removelocal*1);	317	$uri =~ s/^freenet://; $uri = "freenet:$uri";
		318
		319	$self->txn (client_get => URI => $uri, hops_to_live => xeh (defined $htl ? $htl : 15),
		320	remove_local_key => $removelocal ? "true" : "false");
336	};	321	});
337		322
338	=item MISSING: ClientPut	323	=item $txn = $fcp->txn_client_put ($uri, $metadata, $data, $htl, $removelocal)
		324
		325	=item my $uri = $fcp->client_put ($uri, $metadata, $data, $htl, $removelocal);
		326
		327	Insert a new key. If the client is inserting a CHK, the URI may be
		328	abbreviated as just CHK@. In this case, the node will calculate the
		329	CHK. If the key is a private SSK key, the node will calculcate the public
		330	key and the resulting public URI.
		331
		332	C<$meta> can be a hash reference (same format as returned by
		333	C<Net::FCP::parse_metadata>) or a string.
		334
		335	The result is an arrayref with the keys C<uri>, C<public_key> and C<private_key>.
		336
		337	=cut
		338
		339	$txn->(client_put => sub {
		340	my ($self, $uri, $metadata, $data, $htl, $removelocal) = @_;
		341
		342	$metadata = Net::FCP::Metadata::build_metadata $metadata;
		343	$uri =~ s/^freenet://; $uri = "freenet:$uri";
		344
		345	$self->txn (client_put => URI => $uri,
		346	hops_to_live => xeh (defined $htl ? $htl : 15),
		347	remove_local_key => $removelocal ? "true" : "false",
		348	data => "$metadata$data", metadata_length => xeh length $metadata);
		349	});
		350
		351	} # transactions
339		352
340	=back	353	=back
341		354
342	=head2 THE Net::FCP::Txn CLASS	355	=head2 THE Net::FCP::Txn CLASS
343		356
344	All requests (or transactions) are executed in a asynchroneous way (LIE:	357	All requests (or transactions) are executed in a asynchronous way. For
345	uploads are blocking). For each request, a C<Net::FCP::Txn> object is	358	each request, a C<Net::FCP::Txn> object is created (worse: a tcp
346	created (worse: a tcp connection is created, too).	359	connection is created, too).
347		360
348	For each request there is actually a different subclass (and it's possible	361	For each request there is actually a different subclass (and it's possible
349	to subclass these, although of course not documented).	362	to subclass these, although of course not documented).
350		363
351	The most interesting method is C<result>.	364	The most interesting method is C<result>.
…		…
353	=over 4	366	=over 4
354		367
355	=cut	368	=cut
356		369
357	package Net::FCP::Txn;	370	package Net::FCP::Txn;
		371
		372	use Fcntl;
		373	use Socket;
358		374
359	=item new arg => val,...	375	=item new arg => val,...
360		376
361	Creates a new C<Net::FCP::Txn> object. Not normally used.	377	Creates a new C<Net::FCP::Txn> object. Not normally used.
362		378
…		…
364		380
365	sub new {	381	sub new {
366	my $class = shift;	382	my $class = shift;
367	my $self = bless { @_ }, $class;	383	my $self = bless { @_ }, $class;
368		384
		385	$self->{signal} = AnyEvent->condvar;
		386
		387	$self->{fcp}{txn}{$self} = $self;
		388
369	my $attr = "";	389	my $attr = "";
370	my $data = delete $self->{attr}{data};	390	my $data = delete $self->{attr}{data};
371		391
372	while (my ($k, $v) = each %{$self->{attr}}) {	392	while (my ($k, $v) = each %{$self->{attr}}) {
373	$attr .= (Net::FCP::touc $k) . "=$v\012"	393	$attr .= (Net::FCP::touc $k) . "=$v\012"
374	}	394	}
375		395
376	if (defined $data) {	396	if (defined $data) {
377	$attr .= "DataLength=" . (length $data) . "\012";	397	$attr .= sprintf "DataLength=%x\012", length $data;
378	$data = "Data\012$data";	398	$data = "Data\012$data";
379	} else {	399	} else {
380	$data = "EndMessage\012";	400	$data = "EndMessage\012";
381	}	401	}
382		402
383	my $fh = new IO::Socket::INET	403	socket my $fh, PF_INET, SOCK_STREAM, 0
384	PeerHost => $self->{fcp}{host},	404	or Carp::croak "unable to create new tcp socket: $!";
385	PeerPort => $self->{fcp}{port}
386	or Carp::croak "FCP::txn: unable to connect to $self->{fcp}{host}:$self->{fcp}{port}: $!\n";
387
388	binmode $fh, ":raw";	405	binmode $fh, ":raw";
		406	fcntl $fh, F_SETFL, O_NONBLOCK;
		407	connect $fh, (sockaddr_in $self->{fcp}{port}, inet_aton $self->{fcp}{host});
		408	# and Carp::croak "FCP::txn: unable to connect to $self->{fcp}{host}:$self->{fcp}{port}: $!\n";
389		409
390	if (0) {	410	$self->{sbuf} =
391	print	411	"\x00\x00\x00\x02"
392	Net::FCP::touc $self->{type}, "\012",
393	$attr,
394	$data, "\012";
395	}
396
397	print $fh
398	"\x00\x00", "\x00\x02", # SESSID, PRESID
399	Net::FCP::touc $self->{type}, "\012",	412	. (Net::FCP::touc $self->{type})
400	$attr,	413	. "\012$attr$data";
401	$data;
402		414
403	#$fh->shutdown (1); # freenet buggy?, well, it's java...	415	#shutdown $fh, 1; # freenet buggy?, well, it's java...
404		416
405	$self->{fh} = $fh;	417	$self->{fh} = $fh;
406		418
407	$Net::FCP::regcb->($self);	419	$self->{w} = AnyEvent->io (fh => $fh, poll => 'w', cb => sub { $self->fh_ready_w });
408		420
409	$self;	421	$self;
410	}	422	}
411		423
		424	=item $txn = $txn->cb ($coderef)
		425
		426	Sets a callback to be called when the request is finished. The coderef
		427	will be called with the txn as it's sole argument, so it has to call
		428	C<result> itself.
		429
		430	Returns the txn object, useful for chaining.
		431
		432	Example:
		433
		434	$fcp->txn_client_get ("freenet:CHK....")
		435	->userdata ("ehrm")
		436	->cb(sub {
		437	my $data = shift->result;
		438	});
		439
		440	=cut
		441
		442	sub cb($$) {
		443	my ($self, $cb) = @_;
		444	$self->{cb} = $cb;
		445	$self;
		446	}
		447
		448	=item $txn = $txn->userdata ([$userdata])
		449
		450	Set user-specific data. This is useful in progress callbacks. The data can be accessed
		451	using C<< $txn->{userdata} >>.
		452
		453	Returns the txn object, useful for chaining.
		454
		455	=cut
		456
		457	sub userdata($$) {
		458	my ($self, $data) = @_;
		459	$self->{userdata} = $data;
		460	$self;
		461	}
		462
		463	=item $txn->cancel (%attr)
		464
		465	Cancels the operation with a C<cancel> exception and the given attributes
		466	(consider at least giving the attribute C<reason>).
		467
		468	UNTESTED.
		469
		470	=cut
		471
		472	sub cancel {
		473	my ($self, %attr) = @_;
		474	$self->throw (Net::FCP::Exception->new (cancel => { %attr }));
		475	$self->set_result;
		476	$self->eof;
		477	}
		478
412	sub fh_ready {	479	sub fh_ready_w {
413	my ($self) = @_;	480	my ($self) = @_;
414		481
		482	my $len = syswrite $self->{fh}, $self->{sbuf};
		483
		484	if ($len > 0) {
		485	substr $self->{sbuf}, 0, $len, "";
		486	unless (length $self->{sbuf}) {
		487	fcntl $self->{fh}, F_SETFL, 0;
		488	$self->{w} = AnyEvent->io (fh => $self->{fh}, poll => 'r', cb => sub { $self->fh_ready_r });
		489	}
		490	} elsif (defined $len) {
		491	$self->throw (Net::FCP::Exception->new (network_error => { reason => "unexpected end of file while writing" }));
		492	} else {
		493	$self->throw (Net::FCP::Exception->new (network_error => { reason => "$!" }));
		494	}
		495	}
		496
		497	sub fh_ready_r {
		498	my ($self) = @_;
		499
415	if (sysread $self->{fh}, $self->{buf}, 65536, length $self->{buf}) {	500	if (sysread $self->{fh}, $self->{buf}, 16384 + 1024, length $self->{buf}) {
416	for (;;) {	501	for (;;) {
417	if ($self->{datalen}) {	502	if ($self->{datalen}) {
		503	#warn "expecting new datachunk $self->{datalen}, got ".(length $self->{buf})."\n";#d#
418	if (length $self->{buf} >= $self->{datalen}) {	504	if (length $self->{buf} >= $self->{datalen}) {
419	$self->rcv_data (substr $self->{buf}, 0, $self->{datalen}, "");	505	$self->rcv_data (substr $self->{buf}, 0, delete $self->{datalen}, "");
420	} else {	506	} else {
421	last;	507	last;
422	}	508	}
423	} elsif ($self->{buf} =~ s/^DataChunk\015?\012Length=([0-9a-fA-F]+)\015?\012Data\015?\012//) {	509	} elsif ($self->{buf} =~ s/^DataChunk\015?\012Length=([0-9a-fA-F]+)\015?\012Data\015?\012//) {
424	$self->{datalen} = hex $1;	510	$self->{datalen} = hex $1;
		511	#warn "expecting new datachunk $self->{datalen}\n";#d#
425	} elsif ($self->{buf} =~ s/^([a-zA-Z]+)\015?\012(?:(.+?)\015?\012)?EndMessage\015?\012//s) {	512	} elsif ($self->{buf} =~ s/^([a-zA-Z]+)\015?\012(?:(.+?)\015?\012)?EndMessage\015?\012//s) {
426	$self->rcv ($1, {	513	$self->rcv ($1, {
427	map { my ($a, $b) = split /=/, $_, 2; ((Net::FCP::tolc $a), $b) }	514	map { my ($a, $b) = split /=/, $_, 2; ((Net::FCP::tolc $a), $b) }
428	split /\015?\012/, $2	515	split /\015?\012/, $2
429	});	516	});
430	} else {	517	} else {
431	last;	518	last;
432	}	519	}
433	}	520	}
434	} else {	521	} else {
435	$Net::FCP::unregcb->($self);
436	delete $self->{fh};
437	$self->eof;	522	$self->eof;
438	}	523	}
439	}
440
441	sub rcv_data {
442	my ($self, $chunk) = @_;
443
444	$self->{data} .= $chunk;
445	}	524	}
446		525
447	sub rcv {	526	sub rcv {
448	my ($self, $type, $attr) = @_;	527	my ($self, $type, $attr) = @_;
449		528
…		…
456	} else {	535	} else {
457	warn "received unexpected reply type '$type' for '$self->{type}', ignoring\n";	536	warn "received unexpected reply type '$type' for '$self->{type}', ignoring\n";
458	}	537	}
459	}	538	}
460		539
		540	# used as a default exception thrower
		541	sub rcv_throw_exception {
		542	my ($self, $attr, $type) = @_;
		543	$self->throw (Net::FCP::Exception->new ($type, $attr));
		544	}
		545
		546	*rcv_failed = \&Net::FCP::Txn::rcv_throw_exception;
		547	*rcv_format_error = \&Net::FCP::Txn::rcv_throw_exception;
		548
		549	sub throw {
		550	my ($self, $exc) = @_;
		551
		552	$self->{exception} = $exc;
		553	$self->set_result;
		554	$self->eof; # must be last to avoid loops
		555	}
		556
461	sub set_result {	557	sub set_result {
462	my ($self, $result) = @_;	558	my ($self, $result) = @_;
463		559
464	$self->{result} = $result unless exists $self->{result};	560	unless (exists $self->{result}) {
		561	$self->{result} = $result;
		562	$self->{cb}->($self) if exists $self->{cb};
		563	$self->{signal}->broadcast;
		564	}
465	}	565	}
466		566
467	sub eof {	567	sub eof {
468	my ($self) = @_;	568	my ($self) = @_;
469	$self->set_result;	569
		570	delete $self->{w};
		571	delete $self->{fh};
		572
		573	delete $self->{fcp}{txn}{$self};
		574
		575	unless (exists $self->{result}) {
		576	$self->throw (Net::FCP::Exception->new (short_data => {
		577	reason => "unexpected eof or internal node error",
		578	}));
		579	}
		580	}
		581
		582	sub progress {
		583	my ($self, $type, $attr) = @_;
		584
		585	$self->{fcp}->progress ($self, $type, $attr);
470	}	586	}
471		587
472	=item $result = $txn->result	588	=item $result = $txn->result
473		589
474	Waits until a result is available and then returns it.	590	Waits until a result is available and then returns it.
475		591
476	This waiting is (depending on your event model) not very efficient, as it	592	This waiting is (depending on your event model) not very efficient, as it
477	is done outside the "mainloop".	593	is done outside the "mainloop". The biggest problem, however, is that it's
		594	blocking one thread of execution. Try to use the callback mechanism, if
		595	possible, and call result from within the callback (or after is has been
		596	run), as then no waiting is necessary.
478		597
479	=cut	598	=cut
480		599
481	sub result {	600	sub result {
482	my ($self) = @_;	601	my ($self) = @_;
483		602
484	$Net::FCP::waitcb->() while !exists $self->{result};	603	$self->{signal}->wait while !exists $self->{result};
		604
		605	die $self->{exception} if $self->{exception};
485		606
486	return $self->{result};	607	return $self->{result};
487	}
488
489	sub DESTROY {
490	$Net::FCP::unregcb->($_[0]);
491	}	608	}
492		609
493	package Net::FCP::Txn::ClientHello;	610	package Net::FCP::Txn::ClientHello;
494		611
495	use base Net::FCP::Txn;	612	use base Net::FCP::Txn;
…		…
515	use base Net::FCP::Txn;	632	use base Net::FCP::Txn;
516		633
517	sub rcv_success {	634	sub rcv_success {
518	my ($self, $attr) = @_;	635	my ($self, $attr) = @_;
519		636
520	$self->set_result ($attr);	637	$self->set_result ($attr->{uri});
521	}	638	}
522		639
523	package Net::FCP::Txn::GenerateSVKPair;	640	package Net::FCP::Txn::GenerateSVKPair;
524		641
525	use base Net::FCP::Txn;	642	use base Net::FCP::Txn;
526		643
527	sub rcv_success {	644	sub rcv_success {
528	my ($self, $attr) = @_;	645	my ($self, $attr) = @_;
529
530	$self->set_result ([$attr->{PublicKey}, $attr->{PrivateKey}]);	646	$self->set_result ([$attr->{public_key}, $attr->{private_key}, $attr->{crypto_key}]);
531	}	647	}
532		648
533	package Net::FCP::Txn::InvertPrivateKey;	649	package Net::FCP::Txn::InvertPrivateKey;
534		650
535	use base Net::FCP::Txn;	651	use base Net::FCP::Txn;
536		652
537	sub rcv_success {	653	sub rcv_success {
538	my ($self, $attr) = @_;	654	my ($self, $attr) = @_;
539
540	$self->set_result ($attr->{PublicKey});	655	$self->set_result ($attr->{public_key});
541	}	656	}
542		657
543	package Net::FCP::Txn::GetSize;	658	package Net::FCP::Txn::GetSize;
544		659
545	use base Net::FCP::Txn;	660	use base Net::FCP::Txn;
546		661
547	sub rcv_success {	662	sub rcv_success {
548	my ($self, $attr) = @_;	663	my ($self, $attr) = @_;
549
550	$self->set_result ($attr->{Length});	664	$self->set_result (hex $attr->{length});
		665	}
		666
		667	package Net::FCP::Txn::GetPut;
		668
		669	# base class for get and put
		670
		671	use base Net::FCP::Txn;
		672
		673	*rcv_uri_error = \&Net::FCP::Txn::rcv_throw_exception;
		674	*rcv_route_not_found = \&Net::FCP::Txn::rcv_throw_exception;
		675
		676	sub rcv_restarted {
		677	my ($self, $attr, $type) = @_;
		678
		679	delete $self->{datalength};
		680	delete $self->{metalength};
		681	delete $self->{data};
		682
		683	$self->progress ($type, $attr);
551	}	684	}
552		685
553	package Net::FCP::Txn::ClientGet;	686	package Net::FCP::Txn::ClientGet;
554		687
555	use base Net::FCP::Txn;	688	use base Net::FCP::Txn::GetPut;
		689
		690	*rcv_data_not_found = \&Net::FCP::Txn::rcv_throw_exception;
		691
		692	sub rcv_data {
		693	my ($self, $chunk) = @_;
		694
		695	$self->{data} .= $chunk;
		696
		697	$self->progress ("data", { chunk => length $chunk, received => length $self->{data}, total => $self->{datalength} });
		698
		699	if ($self->{datalength} == length $self->{data}) {
		700	my $data = delete $self->{data};
		701	my $meta = new Net::FCP::Metadata (substr $data, 0, $self->{metalength}, "");
		702
		703	$self->set_result ([$meta, $data]);
		704	$self->eof;
		705	}
		706	}
556		707
557	sub rcv_data_found {	708	sub rcv_data_found {
558	my ($self, $attr) = @_;	709	my ($self, $attr, $type) = @_;
		710
		711	$self->progress ($type, $attr);
559		712
560	$self->{datalength} = hex $attr->{data_length};	713	$self->{datalength} = hex $attr->{data_length};
561	$self->{metalength} = hex $attr->{metadata_length};	714	$self->{metalength} = hex $attr->{metadata_length};
562	}	715	}
563		716
564	sub rcv_restarted {	717	package Net::FCP::Txn::ClientPut;
565	# nop, maybe feedback
566	}
567		718
568	sub eof {	719	use base Net::FCP::Txn::GetPut;
569	my ($self) = @_;
570		720
571	my $data = delete $self->{data};	721	*rcv_size_error = \&Net::FCP::Txn::rcv_throw_exception;
572	my $meta = Net::FCP::parse_metadata substr $data, 0, $self->{metalength}, "";
573		722
		723	sub rcv_pending {
		724	my ($self, $attr, $type) = @_;
		725	$self->progress ($type, $attr);
		726	}
		727
		728	sub rcv_success {
		729	my ($self, $attr, $type) = @_;
574	$self->set_result ([$meta, $data]);	730	$self->set_result ($attr);
		731	}
		732
		733	sub rcv_key_collision {
		734	my ($self, $attr, $type) = @_;
		735	$self->set_result ({ key_collision => 1, %$attr });
575	}	736	}
576		737
577	=back	738	=back
578		739
		740	=head2 The Net::FCP::Exception CLASS
		741
		742	Any unexpected (non-standard) responses that make it impossible to return
		743	the advertised result will result in an exception being thrown when the
		744	C<result> method is called.
		745
		746	These exceptions are represented by objects of this class.
		747
		748	=over 4
		749
		750	=cut
		751
		752	package Net::FCP::Exception;
		753
		754	use overload
		755	'""' => sub {
		756	"Net::FCP::Exception<<$_[0][0]," . (join ":", %{$_[0][1]}) . ">>";
		757	};
		758
		759	=item $exc = new Net::FCP::Exception $type, \%attr
		760
		761	Create a new exception object of the given type (a string like
		762	C<route_not_found>), and a hashref containing additional attributes
		763	(usually the attributes of the message causing the exception).
		764
		765	=cut
		766
		767	sub new {
		768	my ($class, $type, $attr) = @_;
		769
		770	bless [Net::FCP::tolc $type, { %$attr }], $class;
		771	}
		772
		773	=item $exc->type([$type])
		774
		775	With no arguments, returns the exception type. Otherwise a boolean
		776	indicating wether the exception is of the given type is returned.
		777
		778	=cut
		779
		780	sub type {
		781	my ($self, $type) = @_;
		782
		783	@_ >= 2
		784	? $self->[0] eq $type
		785	: $self->[0];
		786	}
		787
		788	=item $exc->attr([$attr])
		789
		790	With no arguments, returns the attributes. Otherwise the named attribute
		791	value is returned.
		792
		793	=cut
		794
		795	sub attr {
		796	my ($self, $attr) = @_;
		797
		798	@_ >= 2
		799	? $self->[1]{$attr}
		800	: $self->[1];
		801	}
		802
		803	=back
		804
579	=head1 SEE ALSO	805	=head1 SEE ALSO
580		806
581	L<http://freenet.sf.net>.	807	L<http://freenet.sf.net>.
582		808
583	=head1 BUGS	809	=head1 BUGS
584		810
585	=head1 AUTHOR	811	=head1 AUTHOR
586		812
587	Marc Lehmann <pcg@goof.com>	813	Marc Lehmann <schmorp@schmorp.de>
588	http://www.goof.com/pcg/marc/	814	http://home.schmorp.de/
589		815
590	=cut	816	=cut
591		817
592	1;	818	1
593		819

Diff Legend

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

Comparing Net-FCP/FCP.pm (file contents): Revision 1.8 by root, Mon Sep 8 01:47:31 2003 UTC vs. Revision 1.41 by root, Thu May 1 15:30:15 2008 UTC

Diff Legend

Comparing Net-FCP/FCP.pm (file contents):
Revision 1.8 by root, Mon Sep 8 01:47:31 2003 UTC vs.
Revision 1.41 by root, Thu May 1 15:30:15 2008 UTC