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

Comparing Net-FCP/FCP.pm (file contents):
Revision 1.13 by root, Wed Sep 10 05:06:16 2003 UTC vs.
Revision 1.40 by root, Sun Dec 23 15:42:48 2007 UTC

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

Diff Legend

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

Comparing Net-FCP/FCP.pm (file contents): Revision 1.13 by root, Wed Sep 10 05:06:16 2003 UTC vs. Revision 1.40 by root, Sun Dec 23 15:42:48 2007 UTC

Diff Legend

Comparing Net-FCP/FCP.pm (file contents):
Revision 1.13 by root, Wed Sep 10 05:06:16 2003 UTC vs.
Revision 1.40 by root, Sun Dec 23 15:42:48 2007 UTC