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

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

Diff Legend

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

Comparing cvsroot/Net-FCP/FCP.pm (file contents): Revision 1.9 by root, Tue Sep 9 06:13:18 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.9 by root, Tue Sep 9 06:13:18 2003 UTC vs.
Revision 1.39 by root, Tue Nov 28 15:18:17 2006 UTC