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

Comparing Net-FCP/FCP.pm (file contents):
Revision 1.8 by root, Mon Sep 8 01:47:31 2003 UTC vs.
Revision 1.34 by root, Wed Jan 12 20:37:33 2005 UTC

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

Diff Legend

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

Comparing Net-FCP/FCP.pm (file contents): Revision 1.8 by root, Mon Sep 8 01:47:31 2003 UTC vs. Revision 1.34 by root, Wed Jan 12 20:37:33 2005 UTC

Diff Legend

Comparing Net-FCP/FCP.pm (file contents):
Revision 1.8 by root, Mon Sep 8 01:47:31 2003 UTC vs.
Revision 1.34 by root, Wed Jan 12 20:37:33 2005 UTC