[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.38 by root, Mon Nov 27 13:16:25 2006 UTC

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

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.38 by root, Mon Nov 27 13:16:25 2006 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.38 by root, Mon Nov 27 13:16:25 2006 UTC