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

Comparing Net-FCP/FCP.pm (file contents):
Revision 1.2 by root, Sun Sep 7 23:20:20 2003 UTC vs.
Revision 1.32 by root, Fri May 14 17:25:17 2004 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.01;	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',	83
45	cb => sub {	84	our $EVENT = Net::FCP::Event::Auto::;
46	$obj->fh_ready;	85
		86	sub import {
		87	shift;
		88
		89	for (@_) {
		90	if (/^event=(\w+)$/) {
		91	$EVENT = "Net::FCP::Event::$1";
		92	eval "require $EVENT";
47	},	93	}
48	);	94	}
		95	die $@ if $@;
49	}	96	}
50		97
51	sub event_unreg_cb {
52	$_[0]{eventdata}
53	and (delete $_[0]{eventdata})->cancel;
54	}
55
56	sub event_wait_cb {
57	Event::one_event();
58	}
59
60	$regcb = \&event_reg_cb;
61	$unregcb = \&event_unreg_cb;
62	$waitcb = \&event_wait_cb;
63
64	sub touc($) {
65	local $_ = shift;
66	1 while s/((?:^\|_)(?:svk\|chk\|uri)(?:_\|$))/\U$1/;
67	s/(?:^\|_)(.)/\U$1/g;
68	$_;
69	}
70
71	sub tolc($) {
72	local $_ = shift;
73	s/(?<=[a-z])(?=[A-Z])/_/g;
74	lc $_;
75	}
76
77	=item $fcp = new Net::FCP [host => $host][, port => $port]	98	=item $fcp = new Net::FCP [host => $host][, port => $port][, progress => \&cb]
78		99
79	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
80	127.0.0.1:8481).	101	127.0.0.1:8481, or the environment variables C<FREDHOST> and C<FREDPORT>).
81		102
82	Connections are virtual because no persistent physical connection is	103	Connections are virtual because no persistent physical connection is
83	established. However, the existance of the node is checked by executing a	104	established.
84	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	}
85		115
86	=cut	116	=cut
87		117
88	sub new {	118	sub new {
89	my $class = shift;	119	my $class = shift;
90	my $self = bless { @_ }, $class;	120	my $self = bless { @_ }, $class;
91		121
92	$self->{host} \|\|= "127.0.0.1";	122	$self->{host} \|\|= $ENV{FREDHOST} \|\| "127.0.0.1";
93	$self->{port} \|\|= 8481;	123	$self->{port} \|\|= $ENV{FREDPORT} \|\| 8481;
94
95	$self->{nodehello} = $self->txn("ClientHello")->result
96	or croak "unable to get nodehello from node\n";
97		124
98	$self;	125	$self;
99	}	126	}
100		127
		128	sub progress {
		129	my ($self, $txn, $type, $attr) = @_;
		130
		131	$self->{progress}->($self, $txn, $type, $attr)
		132	if $self->{progress};
		133	}
		134
101	=item $txn = $fcp->txn(type => attr => val,...)	135	=item $txn = $fcp->txn (type => attr => val,...)
102		136
103	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	);
104		159
105	=cut	160	=cut
106		161
107	sub txn {	162	sub txn {
108	my ($self, $type, %attr) = @_;	163	my ($self, $type, %attr) = @_;
109		164
110	$type = touc $type;	165	$type = touc $type;
111		166
112	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);
113		168
114	$txn;	169	$txn;
115	}	170	}
116		171
117	sub _txn($&) {	172	{ # transactions
		173
		174	my $txn = sub {
118	my ($name, $sub) = @_;	175	my ($name, $sub) = @_;
119	*{"$name\_txn"} = $sub;	176	*{"txn_$name"} = $sub;
120	*{$name} = sub { $sub->(@_)->result };	177	*{$name} = sub { $sub->(@_)->result };
121	}	178	};
122		179
123	=item $txn = $fcp->txn_client_hello	180	=item $txn = $fcp->txn_client_hello
124		181
125	=item $nodehello = $fcp->client_hello	182	=item $nodehello = $fcp->client_hello
126		183
127	Executes a ClientHello request and returns it's results.	184	Executes a ClientHello request and returns it's results.
128		185
129	{	186	{
130	max_file_size => "5f5e100",	187	max_file_size => "5f5e100",
		188	node => "Fred,0.6,1.46,7050"
131	protocol => "1.2",	189	protocol => "1.2",
132	node => "Fred,0.6,1.46,7050"
133	}	190	}
134		191
135	=cut	192	=cut
136		193
137	_txn client_hello => sub {	194	$txn->(client_hello => sub {
138	my ($self) = @_;	195	my ($self) = @_;
139		196
140	$self->txn ("client_hello");	197	$self->txn ("client_hello");
141	};	198	});
142		199
143	=item $txn = $fcp->txn_client_info	200	=item $txn = $fcp->txn_client_info
144		201
145	=item $nodeinfo = $fcp->client_info	202	=item $nodeinfo = $fcp->client_info
146		203
147	Executes a ClientInfo request and returns it's results.	204	Executes a ClientInfo request and returns it's results.
148		205
149	{	206	{
150	max_file_size => "5f5e100",
151	datastore_max => "2540be400",
152	node_port => 369,
153	java_name => "Java HotSpot(_T_M) Server VM",
154	operating_system_version => "2.4.20",
155	estimated_load => 52,
156	free_memory => "5cc0148",
157	datastore_free => "5ce03400",
158	node_address => "1.2.3.4",
159	active_jobs => "1f",	207	active_jobs => "1f",
160	allocated_memory => "bde0000",	208	allocated_memory => "bde0000",
161	architecture => "i386",	209	architecture => "i386",
		210	available_threads => 17,
		211	datastore_free => "5ce03400",
		212	datastore_max => "2540be400",
		213	datastore_used => "1f72bb000",
		214	estimated_load => 52,
		215	free_memory => "5cc0148",
		216	is_transient => "false",
		217	java_name => "Java HotSpot(_T_M) Server VM",
		218	java_vendor => "http://www.blackdown.org/",
		219	java_version => "Blackdown-1.4.1-01",
		220	least_recent_timestamp => "f41538b878",
		221	max_file_size => "5f5e100",
		222	most_recent_timestamp => "f77e2cc520"
		223	node_address => "1.2.3.4",
		224	node_port => 369,
		225	operating_system => "Linux",
		226	operating_system_version => "2.4.20",
162	routing_time => "a5",	227	routing_time => "a5",
163	least_recent_timestamp => "f41538b878",
164	available_threads => 17,
165	datastore_used => "1f72bb000",
166	java_version => "Blackdown-1.4.1-01",
167	is_transient => "false",
168	operating_system => "Linux",
169	java_vendor => "http://www.blackdown.org/",
170	most_recent_timestamp => "f77e2cc520"
171	}	228	}
172		229
173	=cut	230	=cut
174		231
175	_txn client_info => sub {	232	$txn->(client_info => sub {
176	my ($self) = @_;	233	my ($self) = @_;
177		234
178	$self->txn ("client_info");	235	$self->txn ("client_info");
179	};	236	});
180		237
181	=item $txn = $fcp->txn_generate_chk ($metadata, $data)	238	=item $txn = $fcp->txn_generate_chk ($metadata, $data[, $cipher])
182		239
183	=item $uri = $fcp->generate_chk ($metadata, $data)	240	=item $uri = $fcp->generate_chk ($metadata, $data[, $cipher])
184		241
185	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.
186		244
187	=cut	245	=cut
188		246
189	_txn generate_chk => sub {	247	$txn->(generate_chk => sub {
190	my ($self, $metadata, $data) = @_;	248	my ($self, $metadata, $data, $cipher) = @_;
191		249
192	$self->txn (generate_chk => data => "$data$metadata", meta_data_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");
193	};	256	});
194		257
195	=item $txn = $fcp->txn_generate_svk_pair	258	=item $txn = $fcp->txn_generate_svk_pair
196		259
197	=item ($public, $private) = @{ $fcp->generate_svk_pair }	260	=item ($public, $private, $crypto) = @{ $fcp->generate_svk_pair }
198		261
199	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.
200		264
201	[	265	[
202	"hKs0-WDQA4pVZyMPKNFsK1zapWY",	266	"acLx4dux9fvvABH15Gk6~d3I-yw",
203	"ZnmvMITaTXBMFGl4~jrjuyWxOWg"	267	"cPoDkDMXDGSMM32plaPZDhJDxSs",
		268	"BH7LXCov0w51-y9i~BoB3g",
204	]	269	]
205		270
206	=cut	271	A private key (for inserting) can be constructed like this:
207		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
208	_txn generate_svk_pair => sub {	283	$txn->(generate_svk_pair => sub {
209	my ($self) = @_;	284	my ($self) = @_;
210		285
211	$self->txn ("generate_svk_pair");	286	$self->txn ("generate_svk_pair");
212	};	287	});
213		288
214	=item $txn = $fcp->txn_insert_private_key ($private)	289	=item $txn = $fcp->txn_invert_private_key ($private)
215		290
216	=item $uri = $fcp->insert_private_key ($private)	291	=item $public = $fcp->invert_private_key ($private)
217		292
218	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
219	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.
220	from C<generate_svk_pair>).	295	the private value you get back from C<generate_svk_pair>).
221		296
222	Returns the public key.	297	Returns the public key.
223		298
224	UNTESTED.
225
226	=cut	299	=cut
227		300
228	_txn insert_private_key => sub {	301	$txn->(invert_private_key => sub {
229	my ($self, $privkey) = @_;	302	my ($self, $privkey) = @_;
230		303
231	$self->txn (invert_private_key => private => $privkey);	304	$self->txn (invert_private_key => private => $privkey);
232	};	305	});
233		306
234	=item $txn = $fcp->txn_get_size ($uri)	307	=item $txn = $fcp->txn_get_size ($uri)
235		308
236	=item $length = $fcp->get_size ($uri)	309	=item $length = $fcp->get_size ($uri)
237		310
238	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
239	given document.	312	given document.
240		313
241	UNTESTED.
242
243	=cut	314	=cut
244		315
245	_txn get_size => sub {	316	$txn->(get_size => sub {
246	my ($self, $uri) = @_;	317	my ($self, $uri) = @_;
247		318
248	$self->txn (get_size => URI => $uri);	319	$self->txn (get_size => URI => $uri);
249	};	320	});
250		321
251	=item MISSING: ClientGet, ClientPut	322	=item $txn = $fcp->txn_client_get ($uri [, $htl = 15 [, $removelocal = 0]])
		323
		324	=item ($metadata, $data) = @{ $fcp->client_get ($uri, $htl, $removelocal)
		325
		326	Fetches a (small, as it should fit into memory) key content block from
		327	freenet. C<$meta> is a C<Net::FCP::Metadata> object or C<undef>).
		328
		329	The C<$uri> should begin with C<freenet:>, but the scheme is currently
		330	added, if missing.
		331
		332	my ($meta, $data) = @{
		333	$fcp->client_get (
		334	"freenet:CHK@hdXaxkwZ9rA8-SidT0AN-bniQlgPAwI,XdCDmBuGsd-ulqbLnZ8v~w"
		335	)
		336	};
		337
		338	=cut
		339
		340	$txn->(client_get => sub {
		341	my ($self, $uri, $htl, $removelocal) = @_;
		342
		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");
		347	});
		348
		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
252		378
253	=back	379	=back
254		380
255	=head2 THE Net::FCP::Txn CLASS	381	=head2 THE Net::FCP::Txn CLASS
256		382
257	All requests (or transactions) are executed in a asynchroneous way (LIE:	383	All requests (or transactions) are executed in a asynchronous way. For
258	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
259	created (worse: a tcp connection is created, too).	385	connection is created, too).
260		386
261	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
262	to subclass these, although of course not documented).	388	to subclass these, although of course not documented).
263		389
264	The most interesting method is C<result>.	390	The most interesting method is C<result>.
…		…
266	=over 4	392	=over 4
267		393
268	=cut	394	=cut
269		395
270	package Net::FCP::Txn;	396	package Net::FCP::Txn;
		397
		398	use Fcntl;
		399	use Socket;
271		400
272	=item new arg => val,...	401	=item new arg => val,...
273		402
274	Creates a new C<Net::FCP::Txn> object. Not normally used.	403	Creates a new C<Net::FCP::Txn> object. Not normally used.
275		404
…		…
277		406
278	sub new {	407	sub new {
279	my $class = shift;	408	my $class = shift;
280	my $self = bless { @_ }, $class;	409	my $self = bless { @_ }, $class;
281		410
		411	$self->{signal} = $EVENT->new_signal;
		412
		413	$self->{fcp}{txn}{$self} = $self;
		414
282	my $attr = "";	415	my $attr = "";
283	my $data = delete $self->{attr}{data};	416	my $data = delete $self->{attr}{data};
284		417
285	while (my ($k, $v) = each %{$self->{attr}}) {	418	while (my ($k, $v) = each %{$self->{attr}}) {
286	$attr .= (Net::FCP::touc $k) . "=$v\012"	419	$attr .= (Net::FCP::touc $k) . "=$v\012"
287	}	420	}
288		421
289	if (defined $data) {	422	if (defined $data) {
290	$attr .= "DataLength=" . (length $data) . "\012";	423	$attr .= sprintf "DataLength=%x\012", length $data;
291	$data = "Data\012$data";	424	$data = "Data\012$data";
292	} else {	425	} else {
293	$data = "EndMessage\012";	426	$data = "EndMessage\012";
294	}	427	}
295		428
296	my $fh = new IO::Socket::INET	429	socket my $fh, PF_INET, SOCK_STREAM, 0
297	PeerHost => $self->{fcp}{host},	430	or Carp::croak "unable to create new tcp socket: $!";
298	PeerPort => $self->{fcp}{port}
299	or Carp::croak "FCP::txn: unable to connect to $self->{fcp}{host}:$self->{fcp}{port}: $!\n";
300
301	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";
302		437
303	if (0) {	438	$self->{sbuf} =
304	print	439	"\x00\x00\x00\x02"
305	Net::FCP::touc $self->{type}, "\012",
306	$attr,
307	$data, "\012";
308	}
309
310	print $fh
311	"\x00\x00", "\x00\x02", # SESSID, PRESID
312	Net::FCP::touc $self->{type}, "\012",	440	. (Net::FCP::touc $self->{type})
313	$attr,	441	. "\012$attr$data";
314	$data;
315		442
316	#$fh->shutdown (1); # freenet buggy?, well, it's java...	443	#shutdown $fh, 1; # freenet buggy?, well, it's java...
317		444
318	$self->{fh} = $fh;	445	$self->{fh} = $fh;
319		446
320	$Net::FCP::regcb->($self);	447	$self->{w} = $EVENT->new_from_fh ($fh)->cb(sub { $self->fh_ready_w })->poll(0, 1, 1);
321		448
322	$self;	449	$self;
323	}	450	}
324		451
		452	=item $txn = $txn->cb ($coderef)
		453
		454	Sets a callback to be called when the request is finished. The coderef
		455	will be called with the txn as it's sole argument, so it has to call
		456	C<result> itself.
		457
		458	Returns the txn object, useful for chaining.
		459
		460	Example:
		461
		462	$fcp->txn_client_get ("freenet:CHK....")
		463	->userdata ("ehrm")
		464	->cb(sub {
		465	my $data = shift->result;
		466	});
		467
		468	=cut
		469
		470	sub cb($$) {
		471	my ($self, $cb) = @_;
		472	$self->{cb} = $cb;
		473	$self;
		474	}
		475
		476	=item $txn = $txn->userdata ([$userdata])
		477
		478	Set user-specific data. This is useful in progress callbacks. The data can be accessed
		479	using C<< $txn->{userdata} >>.
		480
		481	Returns the txn object, useful for chaining.
		482
		483	=cut
		484
		485	sub userdata($$) {
		486	my ($self, $data) = @_;
		487	$self->{userdata} = $data;
		488	$self;
		489	}
		490
		491	=item $txn->cancel (%attr)
		492
		493	Cancels the operation with a C<cancel> exception anf the given attributes
		494	(consider at least giving the attribute C<reason>).
		495
		496	UNTESTED.
		497
		498	=cut
		499
		500	sub cancel {
		501	my ($self, %attr) = @_;
		502	$self->throw (Net::FCP::Exception->new (cancel => { %attr }));
		503	$self->set_result;
		504	$self->eof;
		505	}
		506
325	sub fh_ready {	507	sub fh_ready_w {
		508	my ($self) = @_;
		509
		510	my $len = syswrite $self->{fh}, $self->{sbuf};
		511
		512	if ($len > 0) {
		513	substr $self->{sbuf}, 0, $len, "";
		514	unless (length $self->{sbuf}) {
		515	fcntl $self->{fh}, F_SETFL, 0;
		516	$self->{w}->cb(sub { $self->fh_ready_r })->poll (1, 0, 1);
		517	}
		518	} elsif (defined $len) {
		519	$self->throw (Net::FCP::Exception->new (network_error => { reason => "unexpected end of file while writing" }));
		520	} else {
		521	$self->throw (Net::FCP::Exception->new (network_error => { reason => "$!" }));
		522	}
		523	}
		524
		525	sub fh_ready_r {
326	my ($self) = @_;	526	my ($self) = @_;
327		527
328	if (sysread $self->{fh}, $self->{buf}, 65536, length $self->{buf}) {	528	if (sysread $self->{fh}, $self->{buf}, 65536, length $self->{buf}) {
329	for (;;) {	529	for (;;) {
330	if ($self->{datalen}) {	530	if ($self->{datalen}) {
		531	#warn "expecting new datachunk $self->{datalen}, got ".(length $self->{buf})."\n";#d#
331	if (length $self->{buf} >= $self->{datalen}) {	532	if (length $self->{buf} >= $self->{datalen}) {
332	$self->recv_data (substr $self->{buf}, 0, $self->{datalen}, "");	533	$self->rcv_data (substr $self->{buf}, 0, delete $self->{datalen}, "");
333	} else {	534	} else {
334	last;	535	last;
335	}	536	}
336	} elsif ($self->{buf} =~ s/^DataChunk\015?\012Length=(\d+)\015?\012Data\015?\012//) {	537	} elsif ($self->{buf} =~ s/^DataChunk\015?\012Length=([0-9a-fA-F]+)\015?\012Data\015?\012//) {
337	$self->{datalen} = $1;	538	$self->{datalen} = hex $1;
		539	#warn "expecting new datachunk $self->{datalen}\n";#d#
338	} elsif ($self->{buf} =~ s/^([a-zA-Z]+)\015?\012(.*?)\015?\012EndMessage\015?\012//s) {	540	} elsif ($self->{buf} =~ s/^([a-zA-Z]+)\015?\012(?:(.+?)\015?\012)?EndMessage\015?\012//s) {
339	$self->rcv ($1, {	541	$self->rcv ($1, {
340	map { my ($a, $b) = split /=/, $_, 2; ((Net::FCP::tolc $a), $b) }	542	map { my ($a, $b) = split /=/, $_, 2; ((Net::FCP::tolc $a), $b) }
341	split /\015?\012/, $2	543	split /\015?\012/, $2
342	});	544	});
343	} else {	545	} else {
344	last;	546	last;
345	}	547	}
346	}	548	}
347	} else {	549	} else {
348	$Net::FCP::unregcb->($self);
349	delete $self->{fh};
350	$self->eof;	550	$self->eof;
351	}	551	}
352	}
353
354	sub rcv_data {
355	my ($self, $chunk) = @_;
356	}	552	}
357		553
358	sub rcv {	554	sub rcv {
359	my ($self, $type, $attr) = @_;	555	my ($self, $type, $attr) = @_;
360		556
361	$type = Net::FCP::tolc $type;	557	$type = Net::FCP::tolc $type;
		558
		559	#use PApp::Util; warn PApp::Util::dumpval [$type, $attr];
362		560
363	if (my $method = $self->can("rcv_$type")) {	561	if (my $method = $self->can("rcv_$type")) {
364	$method->($self, $attr, $type);	562	$method->($self, $attr, $type);
365	} else {	563	} else {
366	warn "received unexpected reply type '$type' for '$self->{type}', ignoring\n";	564	warn "received unexpected reply type '$type' for '$self->{type}', ignoring\n";
367	$self->eof;	565	}
		566	}
		567
		568	# used as a default exception thrower
		569	sub rcv_throw_exception {
		570	my ($self, $attr, $type) = @_;
		571	$self->throw (Net::FCP::Exception->new ($type, $attr));
		572	}
		573
		574	*rcv_failed = \&Net::FCP::Txn::rcv_throw_exception;
		575	*rcv_format_error = \&Net::FCP::Txn::rcv_throw_exception;
		576
		577	sub throw {
		578	my ($self, $exc) = @_;
		579
		580	$self->{exception} = $exc;
		581	$self->set_result;
		582	$self->eof; # must be last to avoid loops
		583	}
		584
		585	sub set_result {
		586	my ($self, $result) = @_;
		587
		588	unless (exists $self->{result}) {
		589	$self->{result} = $result;
		590	$self->{cb}->($self) if exists $self->{cb};
		591	$self->{signal}->send;
368	}	592	}
369	}	593	}
370		594
371	sub eof {	595	sub eof {
372	my ($self, $result) = @_;	596	my ($self) = @_;
373		597
374	$self->{result} = $result unless exists $self->{result};	598	delete $self->{w};
		599	delete $self->{fh};
		600
		601	delete $self->{fcp}{txn}{$self};
		602
		603	unless (exists $self->{result}) {
		604	$self->throw (Net::FCP::Exception->new (short_data => {
		605	reason => "unexpected eof or internal node error",
		606	}));
		607	}
		608	}
		609
		610	sub progress {
		611	my ($self, $type, $attr) = @_;
		612
		613	$self->{fcp}->progress ($self, $type, $attr);
375	}	614	}
376		615
377	=item $result = $txn->result	616	=item $result = $txn->result
378		617
379	Waits until a result is available and then returns it.	618	Waits until a result is available and then returns it.
380		619
381	This waiting is (depending on your event modul) not very efficient, as it	620	This waiting is (depending on your event model) not very efficient, as it
382	is done outside the "mainloop".	621	is done outside the "mainloop". The biggest problem, however, is that it's
		622	blocking one thread of execution. Try to use the callback mechanism, if
		623	possible, and call result from within the callback (or after is has been
		624	run), as then no waiting is necessary.
383		625
384	=cut	626	=cut
385		627
386	sub result {	628	sub result {
387	my ($self) = @_;	629	my ($self) = @_;
388		630
389	$Net::FCP::waitcb->() while !exists $self->{result};	631	$self->{signal}->wait while !exists $self->{result};
		632
		633	die $self->{exception} if $self->{exception};
390		634
391	return $self->{result};	635	return $self->{result};
392	}
393
394	sub DESTROY {
395	$Net::FCP::unregcb->($_[0]);
396	}	636	}
397		637
398	package Net::FCP::Txn::ClientHello;	638	package Net::FCP::Txn::ClientHello;
399		639
400	use base Net::FCP::Txn;	640	use base Net::FCP::Txn;
401		641
402	sub rcv_node_hello {	642	sub rcv_node_hello {
403	my ($self, $attr) = @_;	643	my ($self, $attr) = @_;
404		644
405	$self->eof ($attr);	645	$self->set_result ($attr);
406	}	646	}
407		647
408	package Net::FCP::Txn::ClientInfo;	648	package Net::FCP::Txn::ClientInfo;
409		649
410	use base Net::FCP::Txn;	650	use base Net::FCP::Txn;
411		651
412	sub rcv_node_info {	652	sub rcv_node_info {
413	my ($self, $attr) = @_;	653	my ($self, $attr) = @_;
414		654
415	$self->eof ($attr);	655	$self->set_result ($attr);
416	}	656	}
417		657
418	package Net::FCP::Txn::GenerateCHK;	658	package Net::FCP::Txn::GenerateCHK;
419		659
420	use base Net::FCP::Txn;	660	use base Net::FCP::Txn;
421		661
422	sub rcv_success {	662	sub rcv_success {
423	my ($self, $attr) = @_;	663	my ($self, $attr) = @_;
424		664
425	$self->eof ($attr);	665	$self->set_result ($attr->{uri});
426	}	666	}
427		667
428	package Net::FCP::Txn::GenerateSVKPair;	668	package Net::FCP::Txn::GenerateSVKPair;
429		669
430	use base Net::FCP::Txn;	670	use base Net::FCP::Txn;
431		671
432	sub rcv_success {	672	sub rcv_success {
433	my ($self, $attr) = @_;	673	my ($self, $attr) = @_;
434		674	$self->set_result ([$attr->{public_key}, $attr->{private_key}, $attr->{crypto_key}]);
435	$self->eof ([$attr->{PublicKey}, $attr->{PrivateKey}]);
436	}	675	}
437		676
438	package Net::FCP::Txn::InvertPrivateKey;	677	package Net::FCP::Txn::InvertPrivateKey;
439		678
440	use base Net::FCP::Txn;	679	use base Net::FCP::Txn;
441		680
442	sub rcv_success {	681	sub rcv_success {
443	my ($self, $attr) = @_;	682	my ($self, $attr) = @_;
444
445	$self->eof ($attr->{PublicKey});	683	$self->set_result ($attr->{public_key});
446	}	684	}
447		685
448	package Net::FCP::Txn::GetSize;	686	package Net::FCP::Txn::GetSize;
449		687
450	use base Net::FCP::Txn;	688	use base Net::FCP::Txn;
451		689
452	sub rcv_success {	690	sub rcv_success {
453	my ($self, $attr) = @_;	691	my ($self, $attr) = @_;
454
455	$self->eof ($attr->{Length});	692	$self->set_result (hex $attr->{length});
		693	}
		694
		695	package Net::FCP::Txn::GetPut;
		696
		697	# base class for get and put
		698
		699	use base Net::FCP::Txn;
		700
		701	*rcv_uri_error = \&Net::FCP::Txn::rcv_throw_exception;
		702	*rcv_route_not_found = \&Net::FCP::Txn::rcv_throw_exception;
		703
		704	sub rcv_restarted {
		705	my ($self, $attr, $type) = @_;
		706
		707	delete $self->{datalength};
		708	delete $self->{metalength};
		709	delete $self->{data};
		710
		711	$self->progress ($type, $attr);
		712	}
		713
		714	package Net::FCP::Txn::ClientGet;
		715
		716	use base Net::FCP::Txn::GetPut;
		717
		718	*rcv_data_not_found = \&Net::FCP::Txn::rcv_throw_exception;
		719
		720	sub rcv_data {
		721	my ($self, $chunk) = @_;
		722
		723	$self->{data} .= $chunk;
		724
		725	$self->progress ("data", { chunk => length $chunk, received => length $self->{data}, total => $self->{datalength} });
		726
		727	if ($self->{datalength} == length $self->{data}) {
		728	my $data = delete $self->{data};
		729	my $meta = new Net::FCP::Metadata (substr $data, 0, $self->{metalength}, "");
		730
		731	$self->set_result ([$meta, $data]);
		732	$self->eof;
		733	}
		734	}
		735
		736	sub rcv_data_found {
		737	my ($self, $attr, $type) = @_;
		738
		739	$self->progress ($type, $attr);
		740
		741	$self->{datalength} = hex $attr->{data_length};
		742	$self->{metalength} = hex $attr->{metadata_length};
		743	}
		744
		745	package Net::FCP::Txn::ClientPut;
		746
		747	use base Net::FCP::Txn::GetPut;
		748
		749	*rcv_size_error = \&Net::FCP::Txn::rcv_throw_exception;
		750
		751	sub rcv_pending {
		752	my ($self, $attr, $type) = @_;
		753	$self->progress ($type, $attr);
		754	}
		755
		756	sub rcv_success {
		757	my ($self, $attr, $type) = @_;
		758	$self->set_result ($attr);
		759	}
		760
		761	sub rcv_key_collision {
		762	my ($self, $attr, $type) = @_;
		763	$self->set_result ({ key_collision => 1, %$attr });
		764	}
		765
		766	=back
		767
		768	=head2 The Net::FCP::Exception CLASS
		769
		770	Any unexpected (non-standard) responses that make it impossible to return
		771	the advertised result will result in an exception being thrown when the
		772	C<result> method is called.
		773
		774	These exceptions are represented by objects of this class.
		775
		776	=over 4
		777
		778	=cut
		779
		780	package Net::FCP::Exception;
		781
		782	use overload
		783	'""' => sub {
		784	"Net::FCP::Exception<<$_[0][0]," . (join ":", %{$_[0][1]}) . ">>";
		785	};
		786
		787	=item $exc = new Net::FCP::Exception $type, \%attr
		788
		789	Create a new exception object of the given type (a string like
		790	C<route_not_found>), and a hashref containing additional attributes
		791	(usually the attributes of the message causing the exception).
		792
		793	=cut
		794
		795	sub new {
		796	my ($class, $type, $attr) = @_;
		797
		798	bless [Net::FCP::tolc $type, { %$attr }], $class;
		799	}
		800
		801	=item $exc->type([$type])
		802
		803	With no arguments, returns the exception type. Otherwise a boolean
		804	indicating wether the exception is of the given type is returned.
		805
		806	=cut
		807
		808	sub type {
		809	my ($self, $type) = @_;
		810
		811	@_ >= 2
		812	? $self->[0] eq $type
		813	: $self->[0];
		814	}
		815
		816	=item $exc->attr([$attr])
		817
		818	With no arguments, returns the attributes. Otherwise the named attribute
		819	value is returned.
		820
		821	=cut
		822
		823	sub attr {
		824	my ($self, $attr) = @_;
		825
		826	@_ >= 2
		827	? $self->[1]{$attr}
		828	: $self->[1];
456	}	829	}
457		830
458	=back	831	=back
459		832
460	=head1 SEE ALSO	833	=head1 SEE ALSO
…		…
468	Marc Lehmann <pcg@goof.com>	841	Marc Lehmann <pcg@goof.com>
469	http://www.goof.com/pcg/marc/	842	http://www.goof.com/pcg/marc/
470		843
471	=cut	844	=cut
472		845
		846	package Net::FCP::Event::Auto;
		847
		848	my @models = (
		849	[Coro => Coro::Event::],
		850	[Event => Event::],
		851	[Glib => Glib::],
		852	[Tk => Tk::],
		853	);
		854
		855	sub AUTOLOAD {
		856	$AUTOLOAD =~ s/.*://;
		857
		858	for (@models) {
		859	my ($model, $package) = @$_;
		860	if (defined ${"$package\::VERSION"}) {
		861	$EVENT = "Net::FCP::Event::$model";
		862	eval "require $EVENT"; die if $@;
		863	goto &{"$EVENT\::$AUTOLOAD"};
		864	}
		865	}
		866
		867	for (@models) {
		868	my ($model, $package) = @$_;
		869	$EVENT = "Net::FCP::Event::$model";
		870	if (eval "require $EVENT") {
		871	goto &{"$EVENT\::$AUTOLOAD"};
		872	}
		873	}
		874
		875	die "No event module selected for Net::FCP and autodetect failed. Install any of these: Coro, Event, Glib or Tk.";
		876	}
		877
473	1;	878	1;
474		879

Diff Legend

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

Comparing Net-FCP/FCP.pm (file contents): Revision 1.2 by root, Sun Sep 7 23:20:20 2003 UTC vs. Revision 1.32 by root, Fri May 14 17:25:17 2004 UTC

Diff Legend

Comparing Net-FCP/FCP.pm (file contents):
Revision 1.2 by root, Sun Sep 7 23:20:20 2003 UTC vs.
Revision 1.32 by root, Fri May 14 17:25:17 2004 UTC