[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.36 by root, Thu Dec 1 22:07:40 2005 UTC

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

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.36 by root, Thu Dec 1 22:07:40 2005 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.36 by root, Thu Dec 1 22:07:40 2005 UTC