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

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

Diff Legend

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

Comparing Net-FCP/FCP.pm (file contents): Revision 1.8 by root, Mon Sep 8 01:47:31 2003 UTC vs. Revision 1.30 by root, Fri May 14 16:12:26 2004 UTC

Diff Legend

Comparing Net-FCP/FCP.pm (file contents):
Revision 1.8 by root, Mon Sep 8 01:47:31 2003 UTC vs.
Revision 1.30 by root, Fri May 14 16:12:26 2004 UTC