[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.41 by root, Thu May 1 15:30:15 2008 UTC

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

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.41 by root, Thu May 1 15:30:15 2008 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.41 by root, Thu May 1 15:30:15 2008 UTC