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

Comparing cvsroot/Net-FCP/FCP.pm (file contents):
Revision 1.11 by root, Tue Sep 9 18:52:39 2003 UTC vs.
Revision 1.39 by root, Tue Nov 28 15:18:17 2006 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
44	=cut	59	=cut
45		60
46	package Net::FCP;	61	package Net::FCP;
47		62
48	use Carp;	63	use Carp;
49	use IO::Socket::INET;
50		64
51	$VERSION = 0.05;	65	$VERSION = '1.0';
52		66
53	no warnings;	67	no warnings;
54		68
55	our $EVENT = Net::FCP::Event::Auto::;	69	use AnyEvent;
56	$EVENT = Net::FCP::Event::Event;#d#
57		70
58	sub import {	71	use Net::FCP::Metadata;
59	shift;	72	use Net::FCP::Util qw(tolc touc xeh);
60		73
61	for (@_) {
62	if (/^event=(\w+)$/) {
63	$EVENT = "Net::FCP::Event::$1";
64	}
65	}
66	eval "require $EVENT";
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	$hdr->{tolc $k} = $v;
127	}
128
129	if ($data =~ /\GEndPart\015?\012/gc) {
130	} elsif ($data =~ /\GEnd\015?\012/gc) {
131	last;
132	} elsif ($data =~ /\G([A-Za-z0-9.\-]+)\015?\012/gcs) {
133	push @{$meta->{tolc $1}}, $hdr = {};
134	} elsif ($data =~ /\G(.*)/gcs) {
135	die "metadata format error ($1)";
136	}
137	}
138	}
139
140	#$meta->{tail} = substr $data, pos $data;
141
142	$meta;
143	}
144
145	=item $fcp = new Net::FCP [host => $host][, port => $port]	74	=item $fcp = new Net::FCP [host => $host][, port => $port][, progress => \&cb]
146		75
147	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
148	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>).
149		78
150	Connections are virtual because no persistent physical connection is	79	Connections are virtual because no persistent physical connection is
151	established. However, the existance of the node is checked by executing a	80	established.
152	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	}
153		91
154	=cut	92	=cut
155		93
156	sub new {	94	sub new {
157	my $class = shift;	95	my $class = shift;
158	my $self = bless { @_ }, $class;	96	my $self = bless { @_ }, $class;
159		97
160	$self->{host} \|\|= $ENV{FREDHOST} \|\| "127.0.0.1";	98	$self->{host} \|\|= $ENV{FREDHOST} \|\| "127.0.0.1";
161	$self->{port} \|\|= $ENV{FREDPORt} \|\| 8481;	99	$self->{port} \|\|= $ENV{FREDPORT} \|\| 8481;
162
163	$self->{nodehello} = $self->client_hello
164	or croak "unable to get nodehello from node\n";
165		100
166	$self;	101	$self;
167	}	102	}
168		103
169	sub progress {	104	sub progress {
170	my ($self, $txn, $type, $attr) = @_;	105	my ($self, $txn, $type, $attr) = @_;
171	warn "progress<$txn,$type," . (join ":", %$attr) . ">\n";
172	}
173		106
		107	$self->{progress}->($self, $txn, $type, $attr)
		108	if $self->{progress};
		109	}
		110
174	=item $txn = $fcp->txn(type => attr => val,...)	111	=item $txn = $fcp->txn (type => attr => val,...)
175		112
176	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	);
177		135
178	=cut	136	=cut
179		137
180	sub txn {	138	sub txn {
181	my ($self, $type, %attr) = @_;	139	my ($self, $type, %attr) = @_;
182		140
183	$type = touc $type;	141	$type = touc $type;
184		142
185	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);
186		144
187	$txn;	145	$txn;
188	}	146	}
189		147
190	sub _txn($&) {	148	{ # transactions
		149
		150	my $txn = sub {
191	my ($name, $sub) = @_;	151	my ($name, $sub) = @_;
192	*{"$name\_txn"} = $sub;	152	*{"txn_$name"} = $sub;
193	*{$name} = sub { $sub->(@_)->result };	153	*{$name} = sub { $sub->(@_)->result };
194	}	154	};
195		155
196	=item $txn = $fcp->txn_client_hello	156	=item $txn = $fcp->txn_client_hello
197		157
198	=item $nodehello = $fcp->client_hello	158	=item $nodehello = $fcp->client_hello
199		159
…		…
205	protocol => "1.2",	165	protocol => "1.2",
206	}	166	}
207		167
208	=cut	168	=cut
209		169
210	_txn client_hello => sub {	170	$txn->(client_hello => sub {
211	my ($self) = @_;	171	my ($self) = @_;
212		172
213	$self->txn ("client_hello");	173	$self->txn ("client_hello");
214	};	174	});
215		175
216	=item $txn = $fcp->txn_client_info	176	=item $txn = $fcp->txn_client_info
217		177
218	=item $nodeinfo = $fcp->client_info	178	=item $nodeinfo = $fcp->client_info
219		179
…		…
243	routing_time => "a5",	203	routing_time => "a5",
244	}	204	}
245		205
246	=cut	206	=cut
247		207
248	_txn client_info => sub {	208	$txn->(client_info => sub {
249	my ($self) = @_;	209	my ($self) = @_;
250		210
251	$self->txn ("client_info");	211	$self->txn ("client_info");
252	};	212	});
253		213
254	=item $txn = $fcp->txn_generate_chk ($metadata, $data)	214	=item $txn = $fcp->txn_generate_chk ($metadata, $data[, $cipher])
255		215
256	=item $uri = $fcp->generate_chk ($metadata, $data)	216	=item $uri = $fcp->generate_chk ($metadata, $data[, $cipher])
257		217
258	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.
259		220
260	=cut	221	=cut
261		222
262	_txn generate_chk => sub {	223	$txn->(generate_chk => sub {
263	my ($self, $metadata, $data) = @_;	224	my ($self, $metadata, $data, $cipher) = @_;
264		225
265	$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");
266	};	232	});
267		233
268	=item $txn = $fcp->txn_generate_svk_pair	234	=item $txn = $fcp->txn_generate_svk_pair
269		235
270	=item ($public, $private) = @{ $fcp->generate_svk_pair }	236	=item ($public, $private, $crypto) = @{ $fcp->generate_svk_pair }
271		237
272	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.
273		240
274	[	241	[
275	"hKs0-WDQA4pVZyMPKNFsK1zapWY",	242	"acLx4dux9fvvABH15Gk6~d3I-yw",
276	"ZnmvMITaTXBMFGl4~jrjuyWxOWg"	243	"cPoDkDMXDGSMM32plaPZDhJDxSs",
		244	"BH7LXCov0w51-y9i~BoB3g",
277	]	245	]
278		246
279	=cut	247	A private key (for inserting) can be constructed like this:
280		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
281	_txn generate_svk_pair => sub {	259	$txn->(generate_svk_pair => sub {
282	my ($self) = @_;	260	my ($self) = @_;
283		261
284	$self->txn ("generate_svk_pair");	262	$self->txn ("generate_svk_pair");
285	};	263	});
286		264
287	=item $txn = $fcp->txn_insert_private_key ($private)	265	=item $txn = $fcp->txn_invert_private_key ($private)
288		266
289	=item $uri = $fcp->insert_private_key ($private)	267	=item $public = $fcp->invert_private_key ($private)
290		268
291	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
292	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.
293	from C<generate_svk_pair>).	271	the private value you get back from C<generate_svk_pair>).
294		272
295	Returns the public key.	273	Returns the public key.
296		274
297	UNTESTED.
298
299	=cut	275	=cut
300		276
301	_txn insert_private_key => sub {	277	$txn->(invert_private_key => sub {
302	my ($self, $privkey) = @_;	278	my ($self, $privkey) = @_;
303		279
304	$self->txn (invert_private_key => private => $privkey);	280	$self->txn (invert_private_key => private => $privkey);
305	};	281	});
306		282
307	=item $txn = $fcp->txn_get_size ($uri)	283	=item $txn = $fcp->txn_get_size ($uri)
308		284
309	=item $length = $fcp->get_size ($uri)	285	=item $length = $fcp->get_size ($uri)
310		286
311	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
312	given document.	288	given document.
313		289
314	UNTESTED.
315
316	=cut	290	=cut
317		291
318	_txn get_size => sub {	292	$txn->(get_size => sub {
319	my ($self, $uri) = @_;	293	my ($self, $uri) = @_;
320		294
321	$self->txn (get_size => URI => $uri);	295	$self->txn (get_size => URI => $uri);
322	};	296	});
323		297
324	=item $txn = $fcp->txn_client_get ($uri [, $htl = 15 [, $removelocal = 0]])	298	=item $txn = $fcp->txn_client_get ($uri [, $htl = 15 [, $removelocal = 0]])
325		299
326	=item ($metadata, $data) = @{ $fcp->client_get ($uri, $htl, $removelocal)	300	=item ($metadata, $data) = @{ $fcp->client_get ($uri, $htl, $removelocal)
327		301
328	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
329	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>).
330	C<undef>).
331		304
332	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.
333		307
334	my ($meta, $data) = @{	308	my ($meta, $data) = @{
335	$fcp->client_get (	309	$fcp->client_get (
336	"freenet:CHK@hdXaxkwZ9rA8-SidT0AN-bniQlgPAwI,XdCDmBuGsd-ulqbLnZ8v~w"	310	"freenet:CHK@hdXaxkwZ9rA8-SidT0AN-bniQlgPAwI,XdCDmBuGsd-ulqbLnZ8v~w"
337	)	311	)
338	};	312	};
339		313
340	=cut	314	=cut
341		315
342	_txn client_get => sub {	316	$txn->(client_get => sub {
343	my ($self, $uri, $htl, $removelocal) = @_;	317	my ($self, $uri, $htl, $removelocal) = @_;
344		318
345	$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");
346	};	323	});
347		324
348	=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
349		354
350	=back	355	=back
351		356
352	=head2 THE Net::FCP::Txn CLASS	357	=head2 THE Net::FCP::Txn CLASS
353		358
354	All requests (or transactions) are executed in a asynchroneous way (LIE:	359	All requests (or transactions) are executed in a asynchronous way. For
355	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
356	created (worse: a tcp connection is created, too).	361	connection is created, too).
357		362
358	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
359	to subclass these, although of course not documented).	364	to subclass these, although of course not documented).
360		365
361	The most interesting method is C<result>.	366	The most interesting method is C<result>.
…		…
363	=over 4	368	=over 4
364		369
365	=cut	370	=cut
366		371
367	package Net::FCP::Txn;	372	package Net::FCP::Txn;
		373
		374	use Fcntl;
		375	use Socket;
368		376
369	=item new arg => val,...	377	=item new arg => val,...
370		378
371	Creates a new C<Net::FCP::Txn> object. Not normally used.	379	Creates a new C<Net::FCP::Txn> object. Not normally used.
372		380
…		…
374		382
375	sub new {	383	sub new {
376	my $class = shift;	384	my $class = shift;
377	my $self = bless { @_ }, $class;	385	my $self = bless { @_ }, $class;
378		386
		387	$self->{signal} = AnyEvent->condvar;
		388
		389	$self->{fcp}{txn}{$self} = $self;
		390
379	my $attr = "";	391	my $attr = "";
380	my $data = delete $self->{attr}{data};	392	my $data = delete $self->{attr}{data};
381		393
382	while (my ($k, $v) = each %{$self->{attr}}) {	394	while (my ($k, $v) = each %{$self->{attr}}) {
383	$attr .= (Net::FCP::touc $k) . "=$v\012"	395	$attr .= (Net::FCP::touc $k) . "=$v\012"
384	}	396	}
385		397
386	if (defined $data) {	398	if (defined $data) {
387	$attr .= "DataLength=" . (length $data) . "\012";	399	$attr .= sprintf "DataLength=%x\012", length $data;
388	$data = "Data\012$data";	400	$data = "Data\012$data";
389	} else {	401	} else {
390	$data = "EndMessage\012";	402	$data = "EndMessage\012";
391	}	403	}
392		404
393	my $fh = new IO::Socket::INET	405	socket my $fh, PF_INET, SOCK_STREAM, 0
394	PeerHost => $self->{fcp}{host},	406	or Carp::croak "unable to create new tcp socket: $!";
395	PeerPort => $self->{fcp}{port}
396	or Carp::croak "FCP::txn: unable to connect to $self->{fcp}{host}:$self->{fcp}{port}: $!\n";
397
398	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 Carp::croak "FCP::txn: unable to connect to $self->{fcp}{host}:$self->{fcp}{port}: $!\n";
399		411
400	if (0) {	412	$self->{sbuf} =
401	print	413	"\x00\x00\x00\x02"
402	Net::FCP::touc $self->{type}, "\012",
403	$attr,
404	$data, "\012";
405	}
406
407	print $fh
408	"\x00\x00", "\x00\x02", # SESSID, PRESID
409	Net::FCP::touc $self->{type}, "\012",	414	. (Net::FCP::touc $self->{type})
410	$attr,	415	. "\012$attr$data";
411	$data;
412		416
413	#$fh->shutdown (1); # freenet buggy?, well, it's java...	417	#shutdown $fh, 1; # freenet buggy?, well, it's java...
414		418
415	$self->{fh} = $fh;	419	$self->{fh} = $fh;
416		420
417	$EVENT->reg_r_cb ($self);	421	$self->{w} = AnyEvent->io (fh => $fh, poll => 'w', cb => sub { $self->fh_ready_w });
418		422
419	$self;	423	$self;
420	}	424	}
421		425
		426	=item $txn = $txn->cb ($coderef)
		427
		428	Sets a callback to be called when the request is finished. The coderef
		429	will be called with the txn as it's sole argument, so it has to call
		430	C<result> itself.
		431
		432	Returns the txn object, useful for chaining.
		433
		434	Example:
		435
		436	$fcp->txn_client_get ("freenet:CHK....")
		437	->userdata ("ehrm")
		438	->cb(sub {
		439	my $data = shift->result;
		440	});
		441
		442	=cut
		443
		444	sub cb($$) {
		445	my ($self, $cb) = @_;
		446	$self->{cb} = $cb;
		447	$self;
		448	}
		449
422	=item $userdata = $txn->userdata ([$userdata])	450	=item $txn = $txn->userdata ([$userdata])
423		451
424	Get and/or set user-specific data. This is useful in progress callbacks.	452	Set user-specific data. This is useful in progress callbacks. The data can be accessed
		453	using C<< $txn->{userdata} >>.
425		454
426	=cut	455	Returns the txn object, useful for chaining.
427		456
		457	=cut
		458
428	sub userdata($;$) {	459	sub userdata($$) {
429	my ($self, $data) = @_;	460	my ($self, $data) = @_;
430	$self->{userdata} = $data if @_ >= 2;	461	$self->{userdata} = $data;
431	$self->{userdata};	462	$self;
432	}	463	}
433		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
434	sub fh_ready {	481	sub fh_ready_w {
435	my ($self) = @_;	482	my ($self) = @_;
436		483
		484	my $len = syswrite $self->{fh}, $self->{sbuf};
		485
		486	if ($len > 0) {
		487	substr $self->{sbuf}, 0, $len, "";
		488	unless (length $self->{sbuf}) {
		489	fcntl $self->{fh}, F_SETFL, 0;
		490	$self->{w} = AnyEvent->io (fh => $self->{fh}, poll => 'r', cb => sub { $self->fh_ready_r });
		491	}
		492	} elsif (defined $len) {
		493	$self->throw (Net::FCP::Exception->new (network_error => { reason => "unexpected end of file while writing" }));
		494	} else {
		495	$self->throw (Net::FCP::Exception->new (network_error => { reason => "$!" }));
		496	}
		497	}
		498
		499	sub fh_ready_r {
		500	my ($self) = @_;
		501
437	if (sysread $self->{fh}, $self->{buf}, 65536, length $self->{buf}) {	502	if (sysread $self->{fh}, $self->{buf}, 16384 + 1024, length $self->{buf}) {
438	for (;;) {	503	for (;;) {
439	if ($self->{datalen}) {	504	if ($self->{datalen}) {
		505	#warn "expecting new datachunk $self->{datalen}, got ".(length $self->{buf})."\n";#d#
440	if (length $self->{buf} >= $self->{datalen}) {	506	if (length $self->{buf} >= $self->{datalen}) {
441	$self->rcv_data (substr $self->{buf}, 0, delete $self->{datalen}, "");	507	$self->rcv_data (substr $self->{buf}, 0, delete $self->{datalen}, "");
442	} else {	508	} else {
443	last;	509	last;
444	}	510	}
445	} elsif ($self->{buf} =~ s/^DataChunk\015?\012Length=([0-9a-fA-F]+)\015?\012Data\015?\012//) {	511	} elsif ($self->{buf} =~ s/^DataChunk\015?\012Length=([0-9a-fA-F]+)\015?\012Data\015?\012//) {
446	$self->{datalen} = hex $1;	512	$self->{datalen} = hex $1;
		513	#warn "expecting new datachunk $self->{datalen}\n";#d#
447	} elsif ($self->{buf} =~ s/^([a-zA-Z]+)\015?\012(?:(.+?)\015?\012)?EndMessage\015?\012//s) {	514	} elsif ($self->{buf} =~ s/^([a-zA-Z]+)\015?\012(?:(.+?)\015?\012)?EndMessage\015?\012//s) {
448	$self->rcv ($1, {	515	$self->rcv ($1, {
449	map { my ($a, $b) = split /=/, $_, 2; ((Net::FCP::tolc $a), $b) }	516	map { my ($a, $b) = split /=/, $_, 2; ((Net::FCP::tolc $a), $b) }
450	split /\015?\012/, $2	517	split /\015?\012/, $2
451	});	518	});
452	} else {	519	} else {
453	last;	520	last;
454	}	521	}
455	}	522	}
456	} else {	523	} else {
457	$EVENT->unreg_r_cb ($self);
458	delete $self->{fh};
459	$self->eof;	524	$self->eof;
460	}	525	}
461	}
462
463	sub rcv_data {
464	my ($self, $chunk) = @_;
465
466	$self->{data} .= $chunk;
467
468	$self->progress ("data", { chunk => length $chunk, total => length $self->{data}, end => $self->{datalength} });
469	}	526	}
470		527
471	sub rcv {	528	sub rcv {
472	my ($self, $type, $attr) = @_;	529	my ($self, $type, $attr) = @_;
473		530
…		…
480	} else {	537	} else {
481	warn "received unexpected reply type '$type' for '$self->{type}', ignoring\n";	538	warn "received unexpected reply type '$type' for '$self->{type}', ignoring\n";
482	}	539	}
483	}	540	}
484		541
		542	# used as a default exception thrower
		543	sub rcv_throw_exception {
		544	my ($self, $attr, $type) = @_;
		545	$self->throw (Net::FCP::Exception->new ($type, $attr));
		546	}
		547
		548	*rcv_failed = \&Net::FCP::Txn::rcv_throw_exception;
		549	*rcv_format_error = \&Net::FCP::Txn::rcv_throw_exception;
		550
485	sub throw {	551	sub throw {
486	my ($self, $exc) = @_;	552	my ($self, $exc) = @_;
487		553
488	$self->{exception} = $exc;	554	$self->{exception} = $exc;
489	$self->set_result (1);	555	$self->set_result;
		556	$self->eof; # must be last to avoid loops
490	}	557	}
491		558
492	sub set_result {	559	sub set_result {
493	my ($self, $result) = @_;	560	my ($self, $result) = @_;
494		561
495	$self->{result} = $result unless exists $self->{result};	562	unless (exists $self->{result}) {
		563	$self->{result} = $result;
		564	$self->{cb}->($self) if exists $self->{cb};
		565	$self->{signal}->broadcast;
		566	}
496	}	567	}
497		568
498	sub eof {	569	sub eof {
499	my ($self) = @_;	570	my ($self) = @_;
500	$self->set_result;	571
		572	delete $self->{w};
		573	delete $self->{fh};
		574
		575	delete $self->{fcp}{txn}{$self};
		576
		577	unless (exists $self->{result}) {
		578	$self->throw (Net::FCP::Exception->new (short_data => {
		579	reason => "unexpected eof or internal node error",
		580	}));
		581	}
501	}	582	}
502		583
503	sub progress {	584	sub progress {
504	my ($self, $type, $attr) = @_;	585	my ($self, $type, $attr) = @_;
		586
505	$self->{fcp}->progress ($self, $type, $attr);	587	$self->{fcp}->progress ($self, $type, $attr);
506	}	588	}
507		589
508	=item $result = $txn->result	590	=item $result = $txn->result
509		591
510	Waits until a result is available and then returns it.	592	Waits until a result is available and then returns it.
511		593
512	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
513	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.
514		599
515	=cut	600	=cut
516		601
517	sub result {	602	sub result {
518	my ($self) = @_;	603	my ($self) = @_;
519		604
520	$EVENT->wait_event while !exists $self->{result};	605	$self->{signal}->wait while !exists $self->{result};
521		606
522	die $self->{exception} if $self->{exception};	607	die $self->{exception} if $self->{exception};
523		608
524	return $self->{result};	609	return $self->{result};
525	}
526
527	sub DESTROY {
528	$EVENT->unreg_r_cb ($_[0]);
529	#$EVENT->unreg_w_cb ($_[0]);
530	}	610	}
531		611
532	package Net::FCP::Txn::ClientHello;	612	package Net::FCP::Txn::ClientHello;
533		613
534	use base Net::FCP::Txn;	614	use base Net::FCP::Txn;
…		…
554	use base Net::FCP::Txn;	634	use base Net::FCP::Txn;
555		635
556	sub rcv_success {	636	sub rcv_success {
557	my ($self, $attr) = @_;	637	my ($self, $attr) = @_;
558		638
559	$self->set_result ($attr);	639	$self->set_result ($attr->{uri});
560	}	640	}
561		641
562	package Net::FCP::Txn::GenerateSVKPair;	642	package Net::FCP::Txn::GenerateSVKPair;
563		643
564	use base Net::FCP::Txn;	644	use base Net::FCP::Txn;
565		645
566	sub rcv_success {	646	sub rcv_success {
567	my ($self, $attr) = @_;	647	my ($self, $attr) = @_;
568
569	$self->set_result ([$attr->{PublicKey}, $attr->{PrivateKey}]);	648	$self->set_result ([$attr->{public_key}, $attr->{private_key}, $attr->{crypto_key}]);
570	}	649	}
571		650
572	package Net::FCP::Txn::InvertPrivateKey;	651	package Net::FCP::Txn::InvertPrivateKey;
573		652
574	use base Net::FCP::Txn;	653	use base Net::FCP::Txn;
575		654
576	sub rcv_success {	655	sub rcv_success {
577	my ($self, $attr) = @_;	656	my ($self, $attr) = @_;
578
579	$self->set_result ($attr->{PublicKey});	657	$self->set_result ($attr->{public_key});
580	}	658	}
581		659
582	package Net::FCP::Txn::GetSize;	660	package Net::FCP::Txn::GetSize;
583		661
584	use base Net::FCP::Txn;	662	use base Net::FCP::Txn;
585		663
586	sub rcv_success {	664	sub rcv_success {
587	my ($self, $attr) = @_;	665	my ($self, $attr) = @_;
588
589	$self->set_result ($attr->{Length});	666	$self->set_result (hex $attr->{length});
		667	}
		668
		669	package Net::FCP::Txn::GetPut;
		670
		671	# base class for get and put
		672
		673	use base Net::FCP::Txn;
		674
		675	*rcv_uri_error = \&Net::FCP::Txn::rcv_throw_exception;
		676	*rcv_route_not_found = \&Net::FCP::Txn::rcv_throw_exception;
		677
		678	sub rcv_restarted {
		679	my ($self, $attr, $type) = @_;
		680
		681	delete $self->{datalength};
		682	delete $self->{metalength};
		683	delete $self->{data};
		684
		685	$self->progress ($type, $attr);
590	}	686	}
591		687
592	package Net::FCP::Txn::ClientGet;	688	package Net::FCP::Txn::ClientGet;
593		689
594	use base Net::FCP::Txn;	690	use base Net::FCP::Txn::GetPut;
		691
		692	*rcv_data_not_found = \&Net::FCP::Txn::rcv_throw_exception;
		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	}
595		709
596	sub rcv_data_found {	710	sub rcv_data_found {
597	my ($self, $attr, $type) = @_;	711	my ($self, $attr, $type) = @_;
598		712
599	$self->progress ($type, $attr);	713	$self->progress ($type, $attr);
600		714
601	$self->{datalength} = hex $attr->{data_length};	715	$self->{datalength} = hex $attr->{data_length};
602	$self->{metalength} = hex $attr->{metadata_length};	716	$self->{metalength} = hex $attr->{metadata_length};
603	}	717	}
604		718
605	sub rcv_route_not_found {	719	package Net::FCP::Txn::ClientPut;
606	my ($self, $attr, $type) = @_;
607		720
608	$self->throw (new Net::FCP::Exception $type, $attr);	721	use base Net::FCP::Txn::GetPut;
609	}
610		722
611	sub rcv_data_not_found {	723	*rcv_size_error = \&Net::FCP::Txn::rcv_throw_exception;
612	my ($self, $attr, $type) = @_;
613		724
614	$self->throw (new Net::FCP::Exception $type, $attr);	725	sub rcv_pending {
615	}
616
617	sub rcv_format_error {
618	my ($self, $attr, $type) = @_;
619
620	$self->throw (new Net::FCP::Exception $type, $attr);
621	}
622
623	sub rcv_restarted {
624	my ($self, $attr, $type) = @_;	726	my ($self, $attr, $type) = @_;
625	$self->progress ($type, $attr);	727	$self->progress ($type, $attr);
626	}	728	}
627		729
628	sub eof {	730	sub rcv_success {
629	my ($self) = @_;	731	my ($self, $attr, $type) = @_;
630
631	my $data = delete $self->{data};
632	my $meta = Net::FCP::parse_metadata substr $data, 0, $self->{metalength}, "";
633
634	$self->set_result ([$meta, $data]);	732	$self->set_result ($attr);
635	}	733	}
		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
636		753
637	package Net::FCP::Exception;	754	package Net::FCP::Exception;
638		755
639	use overload	756	use overload
640	'""' => sub {	757	'""' => sub {
641	"Net::FCP::Exception<<$_[0][0]," . (join ":", %{$_[0][1]}) . ">>\n";	758	"Net::FCP::Exception<<$_[0][0]," . (join ":", %{$_[0][1]}) . ">>";
642	};	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
643		768
644	sub new {	769	sub new {
645	my ($class, $type, $attr) = @_;	770	my ($class, $type, $attr) = @_;
646		771
647	bless [$type, { %$attr }], $class;	772	bless [Net::FCP::tolc $type, { %$attr }], $class;
		773	}
		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];
648	}	803	}
649		804
650	=back	805	=back
651		806
652	=head1 SEE ALSO	807	=head1 SEE ALSO
…		…
655		810
656	=head1 BUGS	811	=head1 BUGS
657		812
658	=head1 AUTHOR	813	=head1 AUTHOR
659		814
660	Marc Lehmann <pcg@goof.com>	815	Marc Lehmann <schmorp@schmorp.de>
661	http://www.goof.com/pcg/marc/	816	http://home.schmorp.de/
662		817
663	=cut	818	=cut
664		819
665	1;	820	1
666		821

Diff Legend

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

Comparing cvsroot/Net-FCP/FCP.pm (file contents): Revision 1.11 by root, Tue Sep 9 18:52:39 2003 UTC vs. Revision 1.39 by root, Tue Nov 28 15:18:17 2006 UTC

Diff Legend

Comparing cvsroot/Net-FCP/FCP.pm (file contents):
Revision 1.11 by root, Tue Sep 9 18:52:39 2003 UTC vs.
Revision 1.39 by root, Tue Nov 28 15:18:17 2006 UTC